From 28291ed080f0d6816dc60c22687536428400e003 Mon Sep 17 00:00:00 2001 From: Lin Xu Date: Sat, 13 Jun 2020 12:20:43 -0700 Subject: [PATCH 01/13] Advise `call-interactively`; add streaming logging; move profiles to `explain-pause-top'; performance improvements; handle recursive timers > call-interactively In #26, it turns out that hooking `pre-command-hook` is rife with troubles, because elisp can call it and we cannot be sure that the calls are matched. After a lot of thought, instead redesign the measurement engine to advise `call-interactively` instead. This gives much more accurate data for minibuffer, so we don't need the minibuffer hooks either. This work also fixes #18, because now `call-inteactively` time spent in native waits for keyboard input (from interactive specs) are excluded. To do this, this PR introduces proper frame records and stack. I have some concern about the memory usage of this and how well the GC collects the unused branches of the tree. Native frames are inserted whenever elisp is going to call into anything that might wait for keyboard or user input. They are also inserted in between timers and their callbacks, so that in all cases, native wait code has a parent frame to subtract time from. This resolves #31 as well. > streaming logging This change is very large and rebuilds the measurement engine completely. In order not to regress existing bug fixes and also newly fixed bugs, a integration test suite that runs emacs in interactive mode is going to be needed. To enable this, streaming logging of the command records entry/exit/profile/measurement is added to a UNIX socket. The major intent of this is to enable diffing of measurement engine behavior in tests, but it will also allow for out of process visualization of emacs, which will be really useful when GC or blocking stuff happens; you can't see what's actually running right now because we're inside the same process, of course. > Move profiles to `explain-pause-top` and remove `explain-pause-log` and `explain-pause-profiles` The log isn't actually super useful and the UX is not great for it anyway. Since the measurement engine rebuilds the command hook API, I took this chance to fix the display engines as well. Remove `explain-pause-log` and `explain-pause-profiles' as well. Instead, profiles are displayed directly in `explain-pause-top`. Now the limit of profiles applies per command. When `explain-pause-top` is first open, it backfills from the profiling statistics so even if you didn't have it open, it still knows about slow commands. Currrently, I don't have a good UX for native frames yet, so they are hidden from the top view. Fixes #39. Also, while doing this, I had to move the click handlers, so add a new defcustom to allow customization of what actually happens when the profile button is clicked. Fixes #16. `explain-pause-top--table` is extended even more to be even more generic and handle multiple extra lines of full width text after the column header line. This removes the now unused logging `defcustoms`. > Performance improvements to `explain-pause-top` Generally, opt to preallocate vectors of strings and try moderately hard not to allocate memory during refreshes. Also, move to a more consistent double buffering algorithm, which is where we were going anyway. Now we flip between two sets of cached data, which allows re-use of strings even if the entries have moved in order. This also simplifies the code. In tight loops, move let bindings outside the loop, to save on frame allocations. Also, use a recursive timer instead of a interval timer because interval timers will reschedule repeatedly after a delay, and this is not configurable via a binding like I thought before. See emacs bug #41865. > Handle recursive timers If a timer reschedules itself by calling `run-with-timer` within itself, the command stack grows indefinitely and will run out of memory eventually. Fix this by reusing the native command frame if possible; if not, after a certain depth - 64, `explain-pause--timer-frame-max-depth`, not configurable - just reparent the entire stack to root-emacs. --- explain-pause-mode.el | 3202 ++++++++++++++++++++++----------- tests/test-command-logging.el | 13 - tests/test-timers.el | 124 ++ tests/test-top.el | 50 +- 4 files changed, 2281 insertions(+), 1108 deletions(-) create mode 100644 tests/test-timers.el diff --git a/explain-pause-mode.el b/explain-pause-mode.el index b08db89..4c643f2 100644 --- a/explain-pause-mode.el +++ b/explain-pause-mode.el @@ -40,6 +40,7 @@ (require 'seq) (require 'profiler) (require 'subr-x) +(require 'nadvice) ;; customizable behavior (defgroup explain-pause nil @@ -62,6 +63,11 @@ :prefix "explain-pause-profile-" :group 'explain-pause) +(defgroup explain-pause-top nil + "Explain pause top major mode" + :prefix "explain-pause-top-" + :group 'explain-pause) + ;; main behaviors (defcustom explain-pause-slow-too-long-ms 40 @@ -69,6 +75,24 @@ :type 'integer :group 'explain-pause) +(defcustom explain-pause-top-auto-refresh-interval 2 + "How often `explain-pause-top' mode buffers refresh themselves by default, +in seconds. This can be a fraction of a second. If this is nil, they +do not automatically refresh. You can control this on a per buffer basis +by calling `explain-pause-top-auto-refresh'." + :type '(choice (number :tag "Interval (seconds)") + (const :tag "Never" nil)) + :group 'explain-pause-top) + +(defcustom explain-pause-top-click-profile-action #'switch-to-buffer-other-window + "The function that is called when the user clicks on the profile button in +`explain-pause-top' buffers. The function is passed PROFILE-BUFFER, the buffer +which holds the generated profile output. You can customize this to change the +behavior if you wish. The default is to view the buffer using +`switch-to-buffer-other-window'." + :type 'function + :group 'explain-pause-top) + ;; profiling behaviors (defcustom explain-pause-profile-slow-threshold 3 "Explain-pause will profile a slow activity once it has executed slowly this @@ -76,11 +100,6 @@ many times." :type 'integer :group 'explain-pause-profiling) -(defcustom explain-pause-profile-enabled t - "Should explain-pause profile slow activities at all?" - :type 'boolean - :group 'explain-pause-profiling) - (defcustom explain-pause-profile-cpu-sampling-interval 200000 "The CPU sampling interval when the profiler is activated in microseconds. The default value is 2ms." @@ -88,194 +107,53 @@ The default value is 2ms." :group 'explain-pause-profiling) (defcustom explain-pause-profile-saved-profiles 5 - "The number of CPU profiles to save, after which the oldest is removed. -If you change this number, run `explain-pause-profiles-clear' to adjust -the buffer size (but you will lose the current profiles)." + "The number of CPU profiles to save for each command, after which the oldest +is removed. Changes to this number apply to new commands only. If you wish, +you may run `explain-pause-profile-clear' to clear all profiles, though +this will not clear statistics from individual `explain-top-mode' buffers." :type 'integer - :set (lambda (symbol val) - (set-default symbol val) - (explain-pause-profiles-clear)) - :initialize 'custom-initialize-default :group 'explain-pause-profiling) -(defcustom explain-pause-top-auto-refresh-interval 2 - "How often `explain-pause-top' mode buffers refresh themselves by default, -in seconds. This can be a fraction of a second. If this is nil, they -do not automatically refresh. You can control this on a per buffer basis -by calling `explain-pause-top-auto-refresh'." - :type '(choice (number :tag "Interval (seconds)") - (const :tag "Never" nil)) - :group 'explain-pause) - -;; developer logging behaviors -(defcustom explain-pause-log-all-input-loop nil - "Should all command loop executions be logged? WARNING: Very noisy!" - :type 'boolean - :group 'explain-pause-logging) - -(defcustom explain-pause-log-all-timers nil - "Should all timer executions be logged? WARNING: Very noisy!" - :type 'boolean - :group 'explain-pause-logging) - -(defcustom explain-pause-log-all-process-io nil - "Should all process filter executions be logged? WARNING: Very noisy!" - :type 'boolean - :group 'explain-pause-logging) - ;; public hooks (defvar explain-pause-measured-command-hook nil "Functions(s) to call after a command has been measured. The functions are -called with arguments (ms read-io-ms command-set was-profiled). Command-set is -a list of function symbols or strings. +called with an explain-pause-command-record argument. These commands must be fast, because this hook is executed on every command, -not just slow commands.") +not just slow commands. You cannot give up execution in these commands in +any way, e.g. do not call any family of functions that `sit-for', `read-key', +etc. etc.") ;; custom faces (defface explain-pause-top-slow '((t (:foreground "red"))) "The face used to highlight the slow count column when a command is slow -(e.g. > 1 hit).") +(e.g. > 1 hit)." + :group 'explain-pause-top) + +(defface explain-pause-top-profile-heading + '((t (:inherit warning))) + "The face used to highlight the profile heading for commands which have +profiles available to view." + :group 'explain-pause-top) (defface explain-pause-top-changed '((t (:inherit bold))) "The face used to indicate that a value changed since the last refresh of the -buffer.") +buffer." + :group 'explain-pause-top) (defface explain-pause-top-active-column-header '((t (:inherit header-line-highlight))) - "The face used to indicate the currently sorted column in the header line.") - -;; logging functions -(defun explain--as-ms-exact (time) - "Returns the TIME object in exact milliseconds, ignoring picoseconds." - (seq-let [high-seconds low-seconds microseconds] time - (+ (* (+ (* high-seconds 65536) low-seconds) 1000) (/ microseconds 1000)))) - -(let ((explain--log-buffer nil)) - (defun explain--get-log-buffer () - "Get the explain-pause-log buffer or create it if does not exist" - (when (not (buffer-live-p explain--log-buffer)) - (setq explain--log-buffer (get-buffer-create "*explain-pause-log*")) - (with-current-buffer explain--log-buffer - (setq buffer-read-only 1))) - explain--log-buffer)) - -(defun explain--write-to-log (str &optional newline) - "Write a string STR to the log buffer, optionally inserting a NEWLINE." - (with-current-buffer (explain--get-log-buffer) - (let ((inhibit-read-only t)) - (goto-char (point-max)) - (insert (format "%s - " (current-time-string))) - (insert str) - (when newline - (insert "\n")) - (insert "\n") ;; always add a new line between lines - (goto-char (point-max))))) - -(defun explain-pause-mode-change-alert-style (new-style) - "Change the alerting style to NEW-STYLE. Note that this does not change the -customizable variable `explain-pause-alert-style'. - -NEW-STYLE can be: -'developer, where all alerts are shown; -'normal, when alerts are shown when more then 5 have occurred, and not -within 15 minutes of the last time an alert was shown; or -'silent, aka never." - (let ((kinds - '((developer . explain-pause-mode--log-alert-developer) - (normal . explain-pause-mode--log-alert-normal)))) - (dolist (kind kinds) - (remove-hook 'explain-pause-measured-command-hook (cdr kind))) - - (let ((new-hook (assq new-style kinds))) - (when new-hook - (add-hook 'explain-pause-measured-command-hook (cdr new-hook)))))) - -(let ((notification-count 0) - (last-notified (current-time)) - (alert-timer nil)) - (defun explain-pause-mode--log-alert-normal (ms read-ms command-set was-profiled) - "Notify the user of alerts when at least `explain-pause-alert-normal-minimum-count' -alerts have occurred, AND the time since the last notification (or startup) -is greater then `explain-pause-alert-normal-interval' minutes." - (when (> ms explain-pause-slow-too-long-ms) - (setq notification-count (1+ notification-count)) - (when (and (>= notification-count explain-pause-alert-normal-minimum-count) - (> (float-time (time-subtract nil last-notified)) - (* explain-pause-alert-normal-interval 60)) - (not alert-timer)) - (setq alert-timer - (run-with-idle-timer 1 nil - #'explain-pause-mode--log-alert-normal-display))))) - - (defun explain-pause-mode--log-alert-normal-display () - "Display the normal alert to the user but only if the minibuffer is not -active. If it is open, do nothing; at some point later, the conditions will -fire again and this timer will be called again." - (setq alert-timer nil) - ;; if we are not actively in the minibuffer, display our message - (when (not (minibufferp (current-buffer))) - (message "Emacs was slow %d times recently. Run `explain-pause-top' or check `*explain-pause-log*' to learn more." notification-count) - (setq notification-count 0) - (setq last-notified (current-time))))) - -(let ((notifications '()) - (profiled-count 0) - (alert-timer nil)) - (defun explain-pause-mode--log-alert-developer (ms read-ms command-set was-profiled) - "Log all slow and profiling alerts in developer mode. They are gathered until -run-with-idle-timer allows an idle timer to run, and then they are printed -to the minibuffer with a 2 second sit-for." - (when (> ms explain-pause-slow-too-long-ms) - (push ms notifications) - (when was-profiled - (setq profiled-count (1+ profiled-count))) - (unless alert-timer - (setq alert-timer - (run-with-idle-timer 0.5 nil - #'explain-pause-mode--log-alert-developer-display))))) - - (defun explain-pause-mode--log-alert-developer-display () - "Display the last set of notifications in the echo area when the minibuffer is -not active." - (if (minibufferp (current-buffer)) - ;; try again - (setq alert-timer - (run-with-idle-timer 0.5 nil - #'explain-pause-mode--log-alert-developer-display)) - ;; ok, let's draw - (message "Emacs was slow: %s ms%s" - (mapconcat #'number-to-string notifications ", ") - (if (> profiled-count 0) - (format " of which %d were profiled. Run `explain-pause-profiles' to learn more." - profiled-count) - ". Run `explain-pause-top' or check `*explain-pause-log*' to learn more.")) - ;; reset so more notifications can pile up while we wait - (setq notifications '()) - (setq profiled-count 0) - (sit-for 2) - (message nil) - ;; don't let us get rescheduled until we're really done. - (setq alert-timer nil)))) + "The face used to indicate the currently sorted column in the header line." + :group 'explain-pause-top) -;; logging customization -;; depressingly can't define it at the top because `explain-pause-mode-change-alert-style -;; isn't defined yet... -(defcustom explain-pause-alert-style 'normal - "How often should explain-pause alert you about slow pauses in the mini-buffer? - -Changing this value immediately adjusts the behavior. You can do this manually by -calling `explain-pause-mode-change-alert-style' directly if you wish. Note that -calling that function does not change this value." - :type '(choice (const :tag "Always" developer) - (const :tag "Every now and then" normal) - (const :tag "Never" silent)) - :group 'explain-pause - :set (lambda (symbol val) - (set-default symbol val) - (explain-pause-mode-change-alert-style val))) +;; time lists are too expensive to create every single call +;; convert to a integer of ms. +(defsubst explain-pause--as-ms-exact (time) + "Returns the TIME object in exact ms, ignoring picoseconds." + (+ (* (+ (* (nth 0 time) 65536) (nth 1 time)) 1000) + (/ (nth 2 time) 1000))) (defcustom explain-pause-alert-normal-interval 15 "What is the minimum amount of time, in minutes, between alerts when @@ -292,6 +170,7 @@ wish." ;; TODO perhaps this should also display minor modes? probably. minor modes can be interact ;; weirdly and become slow. +;; TODO these aren't used right now (defun explain--buffer-as-string () "Return a human readable string about the buffer (name + major mode)." (format "%s (%s)" @@ -305,11 +184,6 @@ wish." (explain--buffer-as-string))) buffers ", ")) -(defun explain-pause--sanitize-minibuffer (contents) - "Sanitize the minibuffer contents so it does not contain extra whitespace -and especially newlines." - (replace-regexp-in-string "[\n\t ]+" " " contents)) - (defun explain-pause--command-as-string (cmd) "Generate a human readable string for a command CMD. @@ -317,19 +191,21 @@ Normally this is a symbol, when we are in a command loop, but in timers, process filters, etc. this might be a lambda or a bytecompiled lambda. In those cases, also handle if the forms are wrapped by closure. For bytecompiled code, use the references as the best information available. For lambdas and closures, hope -that the argument names are clarifying. We also allow strings for things that go -through minibuffer invocations. Note that in elisp, symbols may have %! So -e.g. this function may generate strings with format specifiers in them." +that the argument names are clarifying. Also subrp is allowed, as we can +generate native frames. We also allow strings for things that need special +representatinos. Note that in elisp, symbols may have %! So e.g. this function +may generate strings with format specifiers in them." (cond ((stringp cmd) cmd) ((symbolp cmd) (symbol-name cmd)) + ;; TODO is there nicer ways to get this? + ((subrp cmd) (prin1-to-string cmd t)) ((byte-code-function-p cmd) ;; "The vector of Lisp objects referenced by the byte code. These include ;; symbols used as function names and variable names." ;; list only symbol references: - (let ((filtered-args - (seq-filter #'symbolp (aref cmd 2)))) - (format " (references: %s)" filtered-args))) + (format " (references: %s)" + (seq-filter #'symbolp (aref cmd 2)))) ((not (listp cmd)) ;; something weird. This should not happen. "Unknown (please file a bug)") @@ -343,6 +219,7 @@ e.g. this function may generate strings with format specifiers in them." (t "Unknown (please file a bug)"))) +;; TODO not used right now... (defun explain-pause--command-set-as-string (command-set) "Format a COMMAND-SET as a human readable string. @@ -352,149 +229,112 @@ blocking execution (or we think so, anyway)." #'explain-pause--command-as-string command-set ", ")) -(defun explain--alert-delays (ms-or-array) - "Display an alert message of duration(s) MS-OR-ARRAY." - (let ((ms-str - (if (listp ms-or-array) - (mapconcat #'prin1-to-string (reverse ms-or-array) ", ") - (prin1-to-string ms-or-array)))) - (message "Emacs blocked for %s ms - check *explain-pause-log*" ms-str))) - -(defun explain--log-pause (diff read-wait-ms command-set log-current-buffer buffer-difference) - "Log the pause to the log. - -DIFF is the ms duration of the pause. -READ-WAIT-MS is the ms duration of any read* functions. -COMMAND-SET is the command-set that paused. -if LOG-CURRENT-BUFFER or BUFFER-DIFFERENCE are not nil, they are logged. These are buffer objects." - ;; use sprintf, it's probably faster (...eh) - (let ((read-wait-str - (if (> read-wait-ms 0) - (format " (read-wait %s ms)" read-wait-ms) - "")) - (buffer-difference-str - (if buffer-difference - (format " (new buffers [%s])" (explain--buffers-as-string buffer-difference)) - "")) - (current-buffer-str - (if log-current-buffer - (format " [%s]" (explain--buffer-as-string)) - "")) - ;; safe; this is formatted as "%s" in next line - (commandset-str (explain-pause--command-set-as-string command-set))) - - (explain--write-to-log - (format "%d ms%s - %s%s%s\n" - diff - read-wait-str - commandset-str - current-buffer-str - buffer-difference-str)))) - ;; profiling functions -(defun explain--profile-report-click-profile (button) - "Click-handler when profile BUTTON is clicked in event profile report view." - (let ((profile (button-get button 'profile))) - (profiler-report-profile-other-frame profile))) - -(defun explain--profile-report-click-refresh (_) - "Click-handler when refresh button is clicked in event profile report view." - (explain-pause-profiles t)) - -(defun explain--profile-report-header (&optional msg) - "Generate a header for the profile report with help text and refesh button. - -The optional parameter MSG is additional flavor text." - (when msg - (insert msg)) - (insert "This buffer is not auto-updated! Run `explain-pause-profiles' or ") - (insert-text-button "[ Refresh ]" - 'action #'explain--profile-report-click-refresh) - (insert "\n\n")) - -(let ((candidates (make-hash-table - :test 'equal)) - (profiles (make-ring explain-pause-profile-saved-profiles))) - - (defun explain-pause-profiles-candidates () - "Return the candidate table of functions that may be profiled soon." - candidates) - - (defun explain-pause-profiles-clear-candidates () - "Clear all entries from the profiling candidates." - (interactive) - (clrhash candidates)) - - (defun explain-pause-profiles-ignore-command (command-set) - "Ignore this command-set from ever being profiled." - ;;TODO (interactive) - (puthash command-set -2 candidates)) - - (defun explain-pause-profiles-force-command (command-set) - "Force this command-set to be profiled the next time it is run, after -which the normal profiling rules apply." - ;;TODO (interactive) - ;;TODO this probably should use regex match against the strings - (puthash command-set -1 candidates)) - - (defun explain-pause-profiles (&optional print-to-buffer) - "Return a list of the saved profiles. Each element is a list of -(time-as-obj diff-in-ms command-set profile). When PRINT-TO-BUFFER is not -nil, the profiles are written human-readable into a temporary buffer, which -is returned. (This buffer is not updated automatically when profiles are -changed.)" - (interactive "p") - (cond - (print-to-buffer - (with-temp-buffer-window - "*explain-pause-profiles*" 'display-buffer-reuse-window nil - (with-current-buffer "*explain-pause-profiles*" - (explain--profile-report-header - (when (ring-empty-p profiles) - "No slow profile entries yet.")) - (dolist (profile (ring-elements profiles)) - (seq-let [time-stamp diff command-set profile] profile - ;; TODO maybe a nicer table or something? There's only a handful of items though. - (insert (format "Slow profile report\n Time: %s\n Command: %s\n Duration: %d ms\n\n" - (current-time-string time-stamp) - (explain-pause--command-set-as-string command-set) - diff)) - (insert-text-button "[ View profile ]" - 'action #'explain--profile-report-click-profile - 'profile profile) - (insert "\n\n")))))) - (t - (ring-elements profiles)))) - - (defun explain-pause-profiles-clear () - "Clear the saved profiles of blocking work." - (interactive) - (setq profiles (make-ring explain-pause-profile-saved-profiles))) - - (defun explain--profile-p (command-set) - "Should this command be profiled?" - (let ((count (gethash command-set candidates 0))) - (and explain-pause-profile-enabled - (or (eq count -1) ;; forced - (>= count - explain-pause-profile-slow-threshold))))) - - (defun explain--store-profile (time diff command-set profile) - "Store the profiling information and reset the profile counter." - ;;TODO probably, we'd like to count how many times a function is profiled - ;;and alert / ignore after some threshold. as it is, we'll continually - ;;profile slow stuff forever. - (puthash command-set 0 candidates) - (ring-insert profiles - (list time diff command-set profile))) - - (defun explain--increment-profile (command-set) - "Increment the profile count for this command-set." - (let ((count (gethash command-set candidates 0))) - ;; only increment if the counter is acting "normal" (-1, -2 special) - (when (>= count 0) - (setq count (1+ count)) - (puthash command-set count candidates))))) +;; TODO :equal list command +(defvar explain-pause-profile--profile-statistics (make-hash-table) + "A hash map of the slow commands and their profiles and profile statistics only. + +This data is always gathered and stored when `explain-pause-mode' is active and +`explain-pause-profile-enabled' is true.") + +(defun explain-pause-profile-clear () + "Clear the profiling data. Note that this does not clear profiles already visible +in any `explain-pause-top' buffers." + (interactive) + (clrhash explain-pause-profile--profile-statistics)) + +(defun explain-pause-profiles-ignore-command (command-set) + "Ignore this command-set from ever being profiled." + ;;TODO (interactive) + t) + +(defsubst explain-pause-profile--count (record) + "Get the count stored for command RECORD from the profile statistics. + +This could be nil if the record has never been seen; -1 if the command has been +set to MUST profile; otherwise a integer value representing how many times it +has been slow." + (let* ((command (explain-pause-command-record-command record)) + (statistic (gethash command explain-pause-profile--profile-statistics nil))) + (when statistic (aref statistic 0)))) + +(defsubst explain-pause-profile--get (record) + "Return the statistics for RECORD, which will be mutated over time. If the +RECORD has never been seen before, this creates a new statistic for it." + (let* ((command (explain-pause-command-record-command record)) + (statistic (gethash command + explain-pause-profile--profile-statistics + nil))) + (unless statistic + (setq statistic (vector 0 nil)) + (puthash command statistic explain-pause-profile--profile-statistics)) + + statistic)) + +(defun explain-pause-profile--command-p (record) + "Should the command in RECORD be profiled?" + ;; TODO should we make this a subst for performance reasons? It runs in every + ;; command invocation... + (let ((count (explain-pause-profile--count record))) + (and count + (or (eq count -1) ;;forced + (>= count explain-pause-profile-slow-threshold))))) + +(defun explain-pause-profile--profile-measured-command (record) + "Record the statistics for this command so we know whether to profile it later. +Store the profile if the record was profiled." + (unless (explain-pause-command-record-native record) + (let ((ms (explain-pause-command-record-executing-time record))) + (when (> ms explain-pause-slow-too-long-ms) + (let* ((profile (explain-pause-command-record-profile record)) + (statistic (explain-pause-profile--get record)) + (count (aref statistic 0))) + + (cond + ;; add the profile if it exists. + ;; we assume that profiles happen relatively rarely, so use + ;; a list so that 'eq comparisons work against head: + (profile + (let* ((head (aref statistic 1)) + (profiles-length (length head)) + (new-entry (vector ms profile))) + + (setf (aref statistic 1) + (if (< profiles-length explain-pause-profile-saved-profiles) + (cons new-entry head) + ;; need to make a duplicate list + (cons new-entry + (seq-take head + (- explain-pause-profile-saved-profiles 1)))))) + + ;; don't forget to clear out the count + (setf (aref statistic 0) 0)) + ((>= count 0) ;; only increment for "non-special" counts + (setf (aref statistic 0) (1+ count))))))))) + +(defun explain-pause-profile-enable (enable) + "Disable profiling if ENABLE is nil, enable otherwise. Disabling or enabling +profiling does not remove existing profiles or profile statistics." + (cond + (enable + (add-hook 'explain-pause-measured-command-hook + #'explain-pause-profile--profile-measured-command)) + (t + (remove-hook 'explain-pause-measured-command-hook + #'explain-pause-profile--profile-measured-command) + t))) + +(defcustom explain-pause-profile-enabled t + "Should explain-pause profile slow activities at all? + +Changing this immediately adjusts the behavior. You can do this manually by +calling `explain-pause-profile-enable' directly. Note that calling that +function does not change this value." + :type 'boolean + :group 'explain-pause-profiling + :set (lambda (symbol val) + (set-default symbol val) + (explain-pause-profile-enable val))) ;; table functions ;; I tried to use `tabulated-list' as well as `ewoc' but I decided to implement @@ -509,6 +349,7 @@ changed.)" (cl-defstruct explain-pause-top--table ;; the list of entries to display, in sorted order + ;; (item prev-display-ptr) ;; to simplify list manipulation code, always have a head (entries (list nil)) ;; the display entries bookkeeping; a list of explain-pause-top--table-display-entry @@ -519,11 +360,15 @@ changed.)" (width 0) ;; whether on next paint, we need to resize (needs-resize t) + ;; the number of COLUMNS, for which each must have a HEADER. + column-count + ;; the number of fields. Fields after COLUMN-COUNT are printed as full lines. + field-count ;; A VECTOR of widths of every column column-widths ;; A VECTOR of widths of every header header-widths - ;; A VECTOR of header titles. must be set before we attempt to draw. + ;; A VECTOR of header titles. must be set before we attempt to draw. (header-titles nil) ;; whether the header is dirty header-dirty @@ -532,19 +377,31 @@ changed.)" ;; A VECTOR of format strings for every column display-column-formats ;; A VECTOR of offsets of every column - display-column-offsets) + display-column-offsets + ;; the index into the buffer vector representing which buffer we are rendering into + buffer-index + ;; the previous buffer index + prev-buffer-index + ;; the width of the buffer (1 + fields + columns) + buffer-width + ;; A scratch diff VECTOR so we don't have to reallocate every draw. + current-diffs + ;; A scratch diff VECTOR of requested widths for COLUMNS so we don't have to reallocate + requested-widths) (cl-defstruct explain-pause-top--table-display-entry + ;; info about the entry in the emacs buffer begin-mark - item-ptr - prev-state + ;; the total display length of this item. begin-market + total-length => '\n' total-length - ;; A bool-vector of whether we need to draw - dirty-columns - ;; A VECTOR of cached strings - cached-strings - ;; A VECTOR of cached string lengths - cached-string-lengths) + + ;; each entry holds a VECTOR of data, one set for each BUFFER + ;; (not emacs buffers, double buffering) + ;; [item-ptr string-vals (0-FIELD) string-lengths (O-COLUMN)] + buffer + + ;; A VECTOR of the dirtiness of FIELDS (nil or t) + dirty-fields) (defun explain-pause-top--table-set-sorter (table new-sort &optional fast-flip) "Change the sort function. Does not re-render. @@ -552,6 +409,8 @@ changed.)" If fast-flip is set, simply reverse the entries. The new sort function must actually implement the reversed order, it (and sort) are just not called." + ;; note that we do not need to copy or move around prev-display-ptr as + ;; no item is added or removed. ;; skip over the head (let* ((entry-ptrs (cdr (explain-pause-top--table-entries table))) (sorted-ptrs (if fast-flip @@ -559,143 +418,33 @@ called." (sort entry-ptrs ;; the sort we do is flipped (lambda (lhs rhs) - (not (funcall new-sort lhs rhs))))))) + (not (funcall new-sort + (car lhs) + (car rhs)))))))) (setf (explain-pause-top--table-entries table) (cons nil sorted-ptrs)) (setf (explain-pause-top--table-sorter table) new-sort))) -(defun explain-pause-top--table-refresh (table) - "Refresh the table of items in the current buffer when requested. Note that -the width cannot be 0." - ;; first, calculate the widths of all the columns. - ;; To do this, now walk through all the entries, updating their current - ;; items as needed, and ask them to prepare to draw. - ;; after, insert new, un-base-marked entries to take care of any new - ;; items. - ;; walk both the display-order and the display-entries - (let* ((display-order-ptr (cdr (explain-pause-top--table-entries table))) - (display-entries-prev (explain-pause-top--table-display-entries table)) - (display-entries-ptr (cdr display-entries-prev)) - (requested-widths (copy-sequence - (explain-pause-top--table-header-widths table))) - (column-count (length requested-widths)) - (layout-changed nil) - (current-diffs (make-vector column-count nil))) - - (while (and display-order-ptr - display-entries-ptr) - (let* ((current-entry (car display-entries-ptr)) - (to-draw-item (car display-order-ptr))) - - (setf (explain-pause-top--table-display-entry-item-ptr current-entry) - to-draw-item) - - (explain-pause-top--table-prepare-draw current-entry requested-widths - current-diffs)) - - (setq display-order-ptr (cdr display-order-ptr)) - (setq display-entries-prev display-entries-ptr) - (setq display-entries-ptr (cdr display-entries-ptr))) - - ;; ok, now reconcile & add new items - ;; prev points to the end now - (while display-order-ptr - (let* ((new-entry (make-explain-pause-top--table-display-entry - :begin-mark nil - :item-ptr (car display-order-ptr) - :prev-state nil - :total-length nil - :dirty-columns (make-bool-vector column-count nil) - :cached-strings (make-vector column-count nil) - :cached-string-lengths (make-vector column-count nil))) - (new-list-entry (list new-entry))) - - (explain-pause-top--table-prepare-draw new-entry requested-widths - current-diffs) - - ;; insert at the tail - (setcdr display-entries-prev new-list-entry) - (setq display-entries-prev new-list-entry) - (setq display-order-ptr (cdr display-order-ptr)))) - - ;; at this point, the following invariants hold: - ;; * every entry has a display-entry (but not all of them have begin-marks) - ;; * columns holds the largest requested width. - ;; * anything that we don't need anymore is starting at display-entries-ptr - ;; check to see if the fixed columns have changed width, OR if our width - ;; changed. If so, we'll force `draw` to draw full lines: - ;; (TODO could we only paint things "after" the first change?) - (when (or - (cl-mismatch (explain-pause-top--table-column-widths table) - requested-widths - :start1 1 - :start2 1 - :test 'eq) - (explain-pause-top--table-needs-resize table)) - - ;; if they are not equal, update the header, format strings, etc. - (explain-pause-top--table-resize-columns - table - ;; convert to a list as resize-columns expects a list of fixed widths - (cdr (append requested-widths nil))) - - (setf (explain-pause-top--table-needs-resize table) nil) - (setq layout-changed t)) - - ;; if the header is dirty, refresh it: - (when (explain-pause-top--table-header-dirty table) - (let ((header - (apply 'format - (explain-pause-top--table-display-full-line-format table) - (append (explain-pause-top--table-header-titles table) nil)))) - (setq header-line-format - `(:eval (explain-pause-top--generate-header-line - ,header - ,(length header) - (window-hscroll) - (- (window-total-width) 1))))) - - (force-mode-line-update) - - (setf (explain-pause-top--table-header-dirty table) nil)) - - ;; now, we are prepared to draw: - (let ((display-draw-ptr - (cdr (explain-pause-top--table-display-entries table)))) - (while display-draw-ptr - (explain-pause-top--table-draw table - (car display-draw-ptr) - layout-changed) - - (setq display-draw-ptr (cdr display-draw-ptr)))) - - ;; move to the beginning of the "no longer needed entries", - ;; wipe, and clear: - (when display-entries-ptr - (let ((mark (explain-pause-top--table-display-entry-begin-mark - (car display-entries-ptr)))) - (delete-region mark (point-max)) - (setcdr display-entries-prev nil))))) - (defun explain-pause-top--table-find-and-insert (table item) - "insert item into the entries, sorted by the current sort function. If the + "insert ITEM into the entries, sorted by the current sort function. If the item is found by the time insertion happens, return the prev item (whose cdr points to the item). If it is not found, return the newly added item. -Comparison of items is by `eq'. If the new item would have been inserted at -the exact same place as the existing item, no insertion occurs, and nil is +Comparison of items is by `eq'. If the new item would have been inserted at the +exact same place as the existing item, no insertion occurs, and nil is returned." (let* ((ptr-entry nil) ;; don't allocate it unless we absolutely need it (display-order-prev (explain-pause-top--table-entries table)) (display-order-ptr (cdr display-order-prev)) (sort-function (explain-pause-top--table-sorter table)) - (saved-dup-item-entry nil)) + (saved-dup-item-entry nil) + (saved-prev-item nil)) ;; insert and search the list at the same time (catch 'inserted (while display-order-ptr - (let ((compare-item (car display-order-ptr))) + (let ((compare-item (caar display-order-ptr))) ;; it is very common we only update a value without changing ;; the order of the list. check for that case here, so we ;; don't create objects just to throw them away in the update @@ -707,17 +456,20 @@ returned." ;; if there is no next, then we are at the end anyway, ;; and certainly we would replace ourselves (when (or (not next-item) - (funcall sort-function (car next-item) item)) - ;; yes: get outta here + (funcall sort-function (caar next-item) item)) + ;; yes: get outta here. (throw 'inserted nil)) - ;; otherwise, skip it + ;; otherwise, record where it is, and skip past it + (setq saved-prev-item (cdar display-order-ptr)) (setq saved-dup-item-entry display-order-prev)) ;; not equal - actual compare: (when (funcall sort-function compare-item item) - ;; we can insert - (setq ptr-entry (list item)) + ;; we can insert. + ;; did we find the item already? if so, copy the prev-ptr, as well + (setq ptr-entry (cons + (cons item saved-prev-item) + display-order-ptr)) (setcdr display-order-prev ptr-entry) - (setcdr ptr-entry display-order-ptr) ;; finish early (throw 'inserted nil))) @@ -725,7 +477,10 @@ returned." (setq display-order-ptr (cdr display-order-ptr)))) ;; at the end, and we didn't insert - (setq ptr-entry (list item)) + (setq ptr-entry (cons + (cons item saved-prev-item) + nil)) + (setcdr display-order-prev ptr-entry)) (or saved-dup-item-entry @@ -749,31 +504,54 @@ table yet, but this will succeed even if this is not true." ;; it means that the place in the list did not change. (when prev ;; otherwise, we have to clean up the old entry: - (when (eq (car prev) item) - ;; it was not found, and the entry returned is the newly inserted - ;; continue searching for the old entry: - (catch 'found - (while ptr - (when (eq (car ptr) item) - ;; prev now points to us - (throw 'found nil)) - (setq prev ptr) - (setq ptr (cdr ptr))))) + (when (eq (caar prev) item) + ;; if the returned item is the item we just inserted, it means + ;; that insert did not find the old item. keep on searching for it: + (let ((new-item prev)) + (catch 'found + (while ptr + (when (eq (caar ptr) item) + ;; prev now points to the old item to delete. + ;; copy the prev-ptr to the new-item + (setcdr (car new-item) (cdar ptr)) + (throw 'found nil)) + (setq prev ptr) + (setq ptr (cdr ptr)))))) ;; ok, splice the old one out (setcdr prev (cdr ptr))))) (defun explain-pause-top--table-clear (table) "Clear all items in the table" + ;; TODO delete all the other entries (setf (explain-pause-top--table-entries table) (list nil))) -(defun explain-pause-top--table-set-headers (table headers) - "Initialize the headers for TABLE. Must be run in the buffer it is expected -to draw in, because it also initializes the header widths." - (setf (explain-pause-top--table-header-titles table) headers) - (setf (explain-pause-top--table-header-widths table) - (cl-map 'vector #'string-width headers)) - (setf (explain-pause-top--table-header-dirty table) t)) +(defun explain-pause-top--table-initialize + (table headers field-count) + "Initialize headers, field infformation, and scratch buffers for TABLE. Must +be run in the buffer it is expected to draw in, because it also initializes +header widths." + (let* ((column-count (length headers)) + (buffer-width (+ 1 field-count column-count))) + ;; field and column sizes + (setf (explain-pause-top--table-column-count table) column-count) + (setf (explain-pause-top--table-field-count table) field-count) + (setf (explain-pause-top--table-buffer-width table) buffer-width) + + ;; scratch objects + (setf (explain-pause-top--table-requested-widths table) + (make-vector column-count nil)) + (setf (explain-pause-top--table-current-diffs table) + (make-vector field-count nil)) + + (setf (explain-pause-top--table-buffer-index table) 0) + (setf (explain-pause-top--table-prev-buffer-index table) buffer-width) + + ;; header info + (setf (explain-pause-top--table-header-dirty table) t) + (setf (explain-pause-top--table-header-titles table) headers) + (setf (explain-pause-top--table-header-widths table) + (cl-map 'vector #'string-width headers)))) (defun explain-pause-top--table-set-header (table idx header) "Set one header to a new value. Must be run in the buffer it is expected to @@ -798,7 +576,6 @@ Columns in WIDTHS get one character padding in between each." be run within the current buffer, as it never runs `string-width'." (let* ((width (explain-pause-top--table-width table)) - (header-titles (explain-pause-top--table-header-titles table)) (total-fixed (+ (apply #'+ fixed-widths) ;; one space between every fixed column (- (length fixed-widths) 1))) @@ -850,6 +627,12 @@ flag. Does not draw, nor recalculate any widths." (setf (explain-pause-top--table-width table) width) (setf (explain-pause-top--table-needs-resize table) t)) +(defconst explain-pause-top--header-left-alignment + (propertize " " 'display (cons 'space (list :align-to 0))) + ;; this is how we deal with left margins fringes and so on, as those are + ;; pixel sized, so we can't print spaces. + "The display property to left align the header to the beginning of the body") + (defun explain-pause-top--generate-header-line (header header-length window-scroll window-width) "Generate a truncated header line. The header scrolls with the text, and @@ -884,14 +667,7 @@ adds '$' when there is more header either front or end." ;; the head padding, which only applies if we've negatively scrolled (head-padding (when (< start 0) - (make-string (- start) ? ))) - - ;; deal with left margins fringes and so on. actually this is a constant - ;; TODO: could we cache it? - (margin-padding (propertize - " " - 'display (cons 'space (list :align-to 0))))) - + (make-string (- start) ? )))) (when head-dots (if (< bounded-start header-length) ;; we need dots at the front and we can move forward. @@ -912,238 +688,561 @@ adds '$' when there is more header either front or end." ;; and we don't have space to insert a $. do nothing (setq end-dot-str nil)))) - (concat margin-padding + (concat explain-pause-top--header-left-alignment head-padding head-dot-str (substring header bounded-start bounded-end) end-dot-str))) +(defun explain-pause-top--concat-to-width (strings width separator) + "Concat STRINGS together with a space until WIDTH is reached, and then insert +SEPARATOR. The width of separator counts towards the next group, not the prior +one. At least one item will always fit in each group, even if the item is wider +then WIDTH." + (let* ((group-length 0) + (reversed-final nil) + (item-ptr strings)) + + (while item-ptr + (let* ((item (car item-ptr)) + (this-length (length item)) + ;; +1 for the space if it's not first item + (try-length (+ group-length this-length + (if (eq group-length 0) 0 1)))) + (if (<= try-length width) + (progn + (setq reversed-final + (cons item + (if (eq group-length 0) + ;; first item + reversed-final + (cons " " reversed-final)))) + (setq group-length try-length) + (setq item-ptr (cdr item-ptr))) + ;; break + (if (> group-length 0) + ;; at least one item has been pushed; + (setq reversed-final + (cons separator reversed-final)) + ;; only this item; push anyway + (setq reversed-final + (cons separator + (cons item reversed-final))) + (setq item-ptr (cdr item-ptr))) + + ;; clear group length for next round + (setq group-length 0)))) + + (apply 'concat (reverse reversed-final)))) + (defun explain-pause-top--split-at-space (string max-lengths) - "Split a string at max-lengths or less, if possible, at a space boundary.If + "Split a string at max-lengths or less, if possible, at a space boundary. If not possible, split at (car MAX-LENGTH) - 1 and add a \\ continuation. Use up MAX-LENGTHS until only one remains, which becomes the final max-length for the rest of the lines." - (save-match-data - (let* ((splits (split-string string " +" t)) - (current-line-length 0) - (current-line nil) - (results nil)) - (while splits - (let* ((this-split (car splits)) - (this-length (length this-split)) - (try (+ current-line-length this-length (length current-line))) - (this-max-length (car max-lengths))) - (if (<= try this-max-length) - ;; fits - (progn - (push this-split current-line) - (setq splits (cdr splits)) - (setq current-line-length (+ current-line-length this-length))) - ;; doesn't fit - (if current-line - ;; some stuff filled, start a new line and try again - (push current-line results) - ;; cut the string up - (let* ((split-point (- this-max-length 1)) - (first-half (substring this-split 0 split-point)) - (second-half (substring this-split split-point))) - (push (list (concat first-half "\\")) results) - (setq splits (cons second-half (cdr splits))))) - - ;; clear the line - (setq current-line nil) - (setq current-line-length 0) - - ;; next max-length - (when (cdr max-lengths) - (setq max-lengths (cdr max-lengths)))))) - - (when current-line - (push current-line results)) - - (cl-loop - for line in (reverse results) - collect (string-join (reverse line) " "))))) - -(defun explain-pause-top--table-item-command-overflow - (table column-widths command-string) - "Return the truncated string for command in first row, and strings for -further lines, if needed." - ;; This really is not very nice, breaking multiple abstraction - ;; layers, but I'm really not convinced yet I want to properly - ;; genericize this table code - (let ((command-column-width (aref column-widths 0))) - (if (< (length command-string) - command-column-width) - ;; it fits. return a polymorphic type because I don't want to - ;; make lists all the time. - command-string - ;; ok, truncate and split: - (let ((lines - (explain-pause-top--split-at-space - command-string - (list command-column-width - (- (explain-pause-top--table-width table) 2)))) - (indent-newline "\n ")) - (cons (car lines) - (concat indent-newline - (string-join (cdr lines) indent-newline))))))) - -(defun explain-pause-top--table-draw (table item force-full-line) - "Redraw an item within it's bounds. - -If the item has a begin-mark, we exist and are replacing text. If not, we're -new; in that case, move to EOB, set begin-mark ourselves. If FORCE-FULL-LINE is -set OR we are new, the entire line is printed, no matter what the dirty-columns -says." - - (let ((begin-mark (explain-pause-top--table-display-entry-begin-mark item)) - (new-item nil) - (cached-strings - (explain-pause-top--table-display-entry-cached-strings item)) - (total-prev-length - (explain-pause-top--table-display-entry-total-length item)) - (column-widths - (explain-pause-top--table-column-widths table))) - - (unless begin-mark - (setq begin-mark (point-max-marker)) - (setf (explain-pause-top--table-display-entry-begin-mark item) begin-mark) - (setq new-item t)) - - (cond - ((or force-full-line - new-item) - ;; draw everything in one shot - (let* ((full-format-string - (explain-pause-top--table-display-full-line-format table)) - ;; TODO special command-str handling here - (command-str (aref cached-strings 0)) - (command-lines (explain-pause-top--table-item-command-overflow - table column-widths command-str)) - (first-line - (if (stringp command-lines) command-lines - (car command-lines))) - (extra-lines - (unless (stringp command-lines) (cdr command-lines))) - ;; Hm. feels slow. - (final-string (concat - (apply 'format full-format-string first-line - (cdr (append cached-strings nil))) - extra-lines))) - - ;; go to the beginning of our region - (goto-char begin-mark) - - (when total-prev-length - ;; we already existed, remove the old - (delete-char total-prev-length)) - - (insert final-string) - - (setf (explain-pause-top--table-display-entry-total-length item) - (length final-string)) - - (unless total-prev-length - ;; we didn't exist, add the newline - (insert "\n")))) - (t - ;; per column update using dirty - (let ((format-strings - (explain-pause-top--table-display-column-formats table)) - (column-offsets - (explain-pause-top--table-display-column-offsets table)) - (dirty-columns - (explain-pause-top--table-display-entry-dirty-columns item))) - - (cl-loop - for column-index from 0 - for dirty-column across dirty-columns - do (when dirty-column - ;; the colunn is dirty; we need to draw - (let ((cached-val (aref cached-strings column-index)) - (format-str (aref format-strings column-index))) - (cond - ((eq column-index 0) - ;; cmd, is special cased due to overflow logic. this could - ;; be cleaned up and abstracted away, but I'm not sure I - ;; want to bother yet - (let* ((command-lines - (explain-pause-top--table-item-command-overflow - table column-widths cached-val)) - (first-line - (if (stringp command-lines) - command-lines - (car command-lines))) - (extra-lines - (unless (stringp command-lines) - (cdr command-lines))) - (printed-first-line (format format-str first-line)) - (width (explain-pause-top--table-width table))) + (let* ((splits (split-string string " +" t)) + (current-line-length 0) + (current-line nil) + (results nil)) + (while splits + (let* ((this-split (car splits)) + (this-length (length this-split)) + (try (+ current-line-length this-length (length current-line))) + (this-max-length (car max-lengths))) + (if (<= try this-max-length) + ;; fits + (progn + (push this-split current-line) + (setq splits (cdr splits)) + (setq current-line-length (+ current-line-length this-length))) + ;; doesn't fit + (if current-line + ;; some stuff filled, start a new line and try again + (push current-line results) + ;; cut the string up + (let* ((split-point (- this-max-length 1)) + (first-half (substring this-split 0 split-point)) + (second-half (substring this-split split-point))) + (push (list (concat first-half "\\")) results) + (setq splits (cons second-half (cdr splits))))) + + ;; clear the line + (setq current-line nil) + (setq current-line-length 0) + + ;; next max-length + (when (cdr max-lengths) + (setq max-lengths (cdr max-lengths)))))) + + (when current-line + (push current-line results)) - ;; TODO hardcoded offset 0 - (goto-char begin-mark) - (delete-char (length printed-first-line)) - (insert printed-first-line) - - ;; now deal with extra lines. total-prev-length must - ;; exist. if the total-prev-length is > width then we - ;; already had extra lines; delete them, insert ours, if - ;; it exists, and update total-prev-lines - (let ((prev-extra-length (- total-prev-length width))) - (goto-char (+ begin-mark width)) - (when (> prev-extra-length 0) - (delete-char prev-extra-length)) - (when extra-lines - (insert extra-lines)) - - (let ((new-total-length (+ width (length extra-lines)))) - (unless (eq new-total-length total-prev-length) - (setf (explain-pause-top--table-display-entry-total-length item) - new-total-length)))))) - (t - ;; normal field. don't do these lookups unless we have to - (let* ((new-str (format format-str cached-val)) - (offset (aref column-offsets column-index))) - (goto-char (+ begin-mark offset)) - (delete-char (length new-str)) - (insert new-str)))))))))))) - -(defun explain-pause-top--table-prepare-draw (item requested-widths column-diffs) - "Prepare to draw an item by generating the converted strings from the values, -and update REQUESTED-WIDTHS with their widths. COLUMN-DIFFS is a temporary vector -used to hold the difference of columns." - (let* ((cached-strings - (explain-pause-top--table-display-entry-cached-strings item)) - (cached-string-lengths - (explain-pause-top--table-display-entry-cached-string-lengths item)) - (dirty-columns (explain-pause-top--table-display-entry-dirty-columns item)) - (item-ptr (explain-pause-top--table-display-entry-item-ptr item)) - (prev-state (explain-pause-top--table-display-entry-prev-state item))) - - ;; ask for any new columns - (setf (explain-pause-top--table-display-entry-prev-state item) - (explain-pause-top--command-entry-compare prev-state item-ptr column-diffs)) - - ;; command-set is safe, all inputs are always formatted in specifiers (cl-loop - for column-index from 0 - for column-diff across column-diffs - for column-width across requested-widths - for dirty-column across-ref dirty-columns - do (let ((compare-width 0)) - (if (not column-diff) - (setq compare-width (aref cached-string-lengths column-index)) - ;; set and update - (let ((new-string-width (string-width column-diff))) - (setf (aref cached-strings column-index) column-diff) - (setf (aref cached-string-lengths column-index) new-string-width) - (setq compare-width new-string-width))) - - (setf dirty-column (not (eq column-diff nil))) - - (when (> compare-width column-width) - (setf (aref requested-widths column-index) compare-width)))))) + for line in (reverse results) + collect (string-join (reverse line) " ")))) + +(defsubst explain-pause-top--table-item-command-overflow + (command-column-width full-width command-string) + "Return nil or the (first, rest) strings for COMMAND-STRING." + ;; TODO this really should be renamed and moved to the command entry + ;; area + (if (< (length command-string) + command-column-width) + ;; it fits + nil + ;; ok, truncate and split: + (let ((lines + (explain-pause-top--split-at-space + command-string + (list command-column-width + (- full-width 2)))) + (indent-newline "\n ")) + (cons (car lines) + (concat indent-newline + (string-join (cdr lines) indent-newline)))))) + +(defsubst explain-pause-top--table-prepare-draw + (entry new-data buffer-index prev-buffer-index + column-count field-count requested-widths field-diffs) + "Prepare to draw ENTRY by setting the item to draw to NEW-DATA, then +generating the converted strings from the values. Store the strings and their +lengths into the buffer at BUFFER-INDEX, using the old values at +PREV-BUFFER-INDEX if useful. Finally, update REQUESTED-WIDTHS and dirty-fields +within the item with their dirtiness. FIELD-DIFFS is a temporary vector used to +hold the difference of fields." + (let* ((to-draw-item (car new-data)) + (prev-draw-entry (cdr new-data)) + (dirty-fields (explain-pause-top--table-display-entry-dirty-fields entry)) + + (buffer (explain-pause-top--table-display-entry-buffer entry)) + (prev-entry-buffer + (when prev-draw-entry + (explain-pause-top--table-display-entry-buffer prev-draw-entry)))) + + ;; given the inputs, ask the entry to fill in the new state with new strings + (setf (aref buffer buffer-index) + (explain-pause-top--command-entry-compare + (aref buffer buffer-index) + ;; the new thing we want to draw + to-draw-item + ;; the previous item drawn here + (aref buffer prev-buffer-index) + ;; the previous drawn of item + (when prev-entry-buffer + (aref prev-entry-buffer prev-buffer-index)) + field-diffs)) + + ;; update the item-ptr's prev-ptr to point to entry. we've saved the + ;; actual prev-ptr already. + (setcdr new-data entry) + + ;; current item-ptr is now filled with the new values, and field-diffs + ;; holds the new strings, or where to copy. + (cl-loop + for field-index from 0 + for buffer-field from (1+ buffer-index) + for prev-buffer-field from 1 + for field-diff across field-diffs + for dirty-field across-ref dirty-fields + with copy-buffer = nil + with is-field = nil + with field-width = 0 + do + (setq is-field (< field-index column-count)) + (cond + ((eq field-diff 'explain-pause-top--table-prev-item) + (setq copy-buffer buffer) + (setq dirty-field nil)) + ((eq field-diff 'explain-pause-top--table-prev-drawn) + (setq copy-buffer prev-entry-buffer) + (setq dirty-field t)) + (t + (setq copy-buffer nil) + (setq dirty-field t))) + + (setf (aref buffer buffer-field) + (if copy-buffer + (aref copy-buffer (+ prev-buffer-index prev-buffer-field)) + field-diff)) + + (when is-field + ;; update stored length + (setq field-width + (if copy-buffer + (aref copy-buffer (+ prev-buffer-index field-count prev-buffer-field)) + (string-width field-diff))) + + (setf (aref buffer (+ buffer-field field-count)) field-width) + + ;; update the requested-width + (when (> field-width + (aref requested-widths field-index)) + (setf (aref requested-widths field-index) field-width)))))) + +(defun explain-pause-top--table-refresh (table) + "Refresh the table of items in the current buffer when requested. Note that +the width cannot be 0." + ;; this is relatively optimized never to allocate memory unless absolutely + ;; needed. + ;; + ;; first, calculate the widths of all the columns. + ;; To do this, now walk through all the entries, updating their current + ;; items as needed, and ask them to prepare to draw. + ;; after, insert new, un-base-marked entries to take care of any new + ;; items. + (let ((display-order-ptr (cdr (explain-pause-top--table-entries table))) + (display-entries-prev (explain-pause-top--table-display-entries table)) + (display-entries-ptr (cdr (explain-pause-top--table-display-entries table))) + + (column-count (explain-pause-top--table-column-count table)) + (field-count (explain-pause-top--table-field-count table)) + + (buffer-index (explain-pause-top--table-buffer-index table)) + (prev-buffer-index (explain-pause-top--table-prev-buffer-index table)) + (buffer-width (explain-pause-top--table-buffer-width table)) + + (requested-widths (explain-pause-top--table-requested-widths table)) + (current-diffs (explain-pause-top--table-current-diffs table)) + + (layout-changed nil)) + + ;; initialize current-diffs with the original header widths + ;; don't use copy-sequence as it creates a new object + (cl-loop + for header-width across (explain-pause-top--table-header-widths table) + for requested-width across-ref requested-widths + do (setf requested-width header-width)) + + ;; walk both the display-order and the display-entries + (while (and display-order-ptr + display-entries-ptr) + + (explain-pause-top--table-prepare-draw + (car display-entries-ptr) + (car display-order-ptr) + buffer-index + prev-buffer-index + column-count + field-count + requested-widths + current-diffs) + + (setq display-order-ptr (cdr display-order-ptr)) + (setq display-entries-prev display-entries-ptr) + (setq display-entries-ptr (cdr display-entries-ptr))) + + ;; ok, now reconcile & add new items + ;; prev points to the end now + (let ((new-list-entry nil) + (new-entry nil)) + (while display-order-ptr + (setq new-entry + (make-explain-pause-top--table-display-entry + :begin-mark nil + :total-length nil + :buffer (make-vector (* 2 buffer-width) nil) + :dirty-fields (make-vector field-count nil))) + (setq new-list-entry (cons new-entry nil)) + + (explain-pause-top--table-prepare-draw + new-entry + (car display-order-ptr) + buffer-index + prev-buffer-index + column-count + field-count + requested-widths + current-diffs) + + ;; insert at the tail + (setcdr display-entries-prev new-list-entry) + (setq display-entries-prev new-list-entry) + (setq display-order-ptr (cdr display-order-ptr)))) + + ;; at this point, the following invariants hold: + ;; * every entry has a display-entry (but not all of them have begin-marks) + ;; * columns holds the largest requested width. + ;; * anything that we don't need anymore is starting at display-entries-ptr + ;; check to see if the fixed columns have changed width, OR if our width + ;; changed. If so, we'll force-draw full lines + (when (or + (explain-pause-top--table-needs-resize table) + (cl-mismatch (explain-pause-top--table-column-widths table) + requested-widths + :start1 1 + :start2 1 + :test 'eq)) + + (when explain-pause-log--send-process + (process-send-string + explain-pause-log--send-process + (format "widths changed %s %s\n" + requested-widths + (explain-pause-top--table-column-widths table)))) + + ;; if they are not equal, update the header, format strings, etc. + (explain-pause-top--table-resize-columns + table + ;; convert to a list as resize-columns expects a list of fixed widths + (cdr (append requested-widths nil))) + + (setf (explain-pause-top--table-needs-resize table) nil) + (setq layout-changed t)) + + ;; if the header is dirty, refresh it: + (when (explain-pause-top--table-header-dirty table) + (let ((header + (apply 'format + (explain-pause-top--table-display-full-line-format table) + (append (explain-pause-top--table-header-titles table) nil)))) + (setq header-line-format + `(:eval (explain-pause-top--generate-header-line + ,header + ,(length header) + (window-hscroll) + (- (window-total-width) 1))))) + + (force-mode-line-update) + + (setf (explain-pause-top--table-header-dirty table) nil)) + + ;; now, we are prepared to draw: + (let ((column-widths + (explain-pause-top--table-column-widths table)) + (table-width (explain-pause-top--table-width table)) + (full-format-string + (explain-pause-top--table-display-full-line-format table)) + (format-strings + (explain-pause-top--table-display-column-formats table)) + (column-offsets + (explain-pause-top--table-display-column-offsets table)) + + (buffer-value-index (1+ buffer-index)) + + (display-draw-ptr + (cdr (explain-pause-top--table-display-entries table))) + + (item nil) + (begin-mark nil) + (total-prev-length nil) + (buffer nil) + (new-item nil) + (dirty-fields nil)) + + (while display-draw-ptr + (setq item (car display-draw-ptr)) + (setq begin-mark (explain-pause-top--table-display-entry-begin-mark item)) + (setq total-prev-length + (explain-pause-top--table-display-entry-total-length item)) + (setq buffer + (explain-pause-top--table-display-entry-buffer item)) + (setq new-item nil) + + (unless begin-mark + (setq begin-mark (point-max-marker)) + (setf (explain-pause-top--table-display-entry-begin-mark item) begin-mark) + (setq new-item t)) + + (cond + ((or layout-changed + new-item) + ;; draw everything in one shot + ;; TODO special command-str handling here + (let* ((command-str (aref buffer (+ buffer-value-index 0))) + ;; when full line is being drawn, always regenerate the cmd + ;; line (TODO this could be optimized) + (cmd-lines + (explain-pause-top--table-item-command-overflow + (aref column-widths 0) + table-width + command-str)) + + (first-command-str (or (car cmd-lines) + command-str)) + + (profile-lines (aref buffer (+ buffer-value-index 6))) + + (extra-lines (concat + (cdr cmd-lines) + ;;TODO special profile handling here + (when profile-lines + (explain-pause-top--concat-to-width + profile-lines + table-width + "\n ")))) + + ;; Hm. feels slow. + (final-string (concat + (apply 'format + full-format-string + first-command-str + (append + (cl-subseq buffer + ;; TODO skip over first + (+ buffer-value-index 1) + (+ buffer-value-index + column-count)) + nil)) + extra-lines))) + + ;; store the cached cmd-lines + ;; TODO + (setf (aref buffer (+ buffer-value-index 5)) cmd-lines) + + ;; go to the beginning of our region + (goto-char begin-mark) + + (when total-prev-length + ;; we already existed, remove the old + (delete-char total-prev-length)) + + (insert final-string) + + (setf (explain-pause-top--table-display-entry-total-length item) + (length final-string)) + + (unless total-prev-length + ;; we didn't exist, add the newline + (insert "\n")))) + (t + ;; per column update using dirty + ;; deal with the real columns first + (setq dirty-fields (explain-pause-top--table-display-entry-dirty-fields item)) + (cl-loop + for column-index from 0 below column-count + for buffer-index from buffer-value-index + for dirty-column across dirty-fields + do (when dirty-column + ;; the colunn is dirty; we need to draw + (let ((cached-val (aref buffer buffer-index)) + (format-str (aref format-strings column-index))) + (cond + ((eq column-index 0) + ;; cmd, is special cased due to overflow logic. this could + ;; be cleaned up and abstracted away, but I'm not sure I + ;; want to bother yet + ;; TODO hardcoded offset 0 + (let ((command-str (aref buffer buffer-index)) + (cmd-lines (aref buffer (+ buffer-value-index 5))) + (printed-first-line nil)) + + (when (eq cmd-lines 'explain-pause-top--table-generate) + ;; need to regenerate it + (setq cmd-lines + (explain-pause-top--table-item-command-overflow + (aref column-widths 0) + table-width + command-str)) + + ;; save it + (setf (aref buffer (+ buffer-value-index 5)) cmd-lines)) + + (setq printed-first-line + (format format-str + (or (car cmd-lines) + command-str))) + + (goto-char begin-mark) + (delete-char (length printed-first-line)) + (insert printed-first-line))) + (t + ;; normal field. don't do these lookups unless we have to + (let* ((new-str (format format-str cached-val)) + (offset (aref column-offsets column-index))) + (goto-char (+ begin-mark offset)) + (delete-char (length new-str)) + (insert new-str))))))) + + ;; now deal with extra lines. only bother if either of the two + ;; columns are dirty. + (when (or (aref dirty-fields 0) + (aref dirty-fields 6)) + (let* ((extra-cmd-lines + (cdr (aref buffer (+ buffer-value-index 5)))) ;; TODO + (profile-lines (aref buffer (+ buffer-value-index 6))) + (extra-lines + (concat extra-cmd-lines + (when profile-lines + (explain-pause-top--concat-to-width + profile-lines + table-width + "\n ")))) + (new-extra-length (length extra-lines)) + (new-total-length (+ table-width new-extra-length)) + (prev-extra-length (- total-prev-length table-width))) + + ;; total-prev-length must exist. if the total-prev-length is > width + ;; then we already had extra lines; delete them, insert ours, if it + ;; exists, and update total-prev-lines + + (goto-char (+ begin-mark table-width)) + (when (> prev-extra-length 0) + (delete-char prev-extra-length)) + (when (> new-extra-length 0) + (insert extra-lines)) + + (unless (eq new-total-length total-prev-length) + (setf (explain-pause-top--table-display-entry-total-length item) + new-total-length)))))) + + (setq display-draw-ptr (cdr display-draw-ptr)))) + + ;; move to the beginning of the "no longer needed entries", + ;; wipe, and clear: + (when display-entries-ptr + (let ((mark (explain-pause-top--table-display-entry-begin-mark + (car display-entries-ptr)))) + (delete-region mark (point-max)) + (setcdr display-entries-prev nil))) + + ;; update the pointers for buffer to flip for next time + (setf (explain-pause-top--table-buffer-index table) prev-buffer-index) + (setf (explain-pause-top--table-prev-buffer-index table) buffer-index))) + +;; the record of an command that we measured +;; theorywise, we are constructing a tree of records, all rooted at "emacs command +;; loop". Idealistically, we could maintain this tree and calculate the timings +;; by subtracting child times from our own. But because elisp actually executes +;; only one thing at a time, structure the graph as a stack and pause tracking +;; as we enter / exit by push/popping - we're traversing the graph as DFS +;; as we execute. +(cl-defstruct explain-pause-command-record + ;; the command this tracked + command + ;; was this a native frame + native + ;; the parent + parent + + ;; timing + ;; the number of ms spent so far. + (executing-time 0) + ;; a TIME object as snap + entry-snap + + ;; profiling: + ;; was profiling was started FOR this command + is-profiled + ;; was profiling started when this command started + under-profile + ;; the profile if it was + profile + + ;; depth of the callstack so far + depth) + +(defsubst explain-pause--command-record-slow-p (record) + "Is the record slow, e.g. longer then `explain-pause-slow-too-long-ms'?" + (> (explain-pause-command-record-executing-time record) + explain-pause-slow-too-long-ms)) + +(defconst explain-pause-root-command-loop + (make-explain-pause-command-record + :command 'root-emacs + :depth 0) + "All command records that `explain-pause' tracks ultimately are rooted to this +command entry, which represents the top level command loop that begins in +`keyboard.c' when called from the initial `recursive_edit' from `emacs.c'.") ;; explain-pause-top-mode ;; buffer-local variables that should be always private @@ -1186,7 +1285,10 @@ to watch for resizes.") slow-count avg-ms total-ms - dirty) + ;; either nil for no, t for yes, 'new for yes and new. + dirty + ;; pointer to the profiles + profiles) (defun explain-pause-top---command-entry-command-set-sorter (lhs rhs) "Sort command-sets alphabetically." @@ -1225,72 +1327,211 @@ to watch for resizes.") (,getter rhs)))))))) (defmacro explain-pause-top--command-entry-column-fields-compare - (prev current diffs cases) - "Generate a list of statements one for each field (car) of CASES which -compares the PREV and CURRENT values of that field. When they do not match, the -cdr of case is run and value stored into DIFFS with the new value bound as -`field-val`. Otherwise nil is stored at that index." - `(let ((dirty-equal (and ,prev - (eq (explain-pause-top--command-entry-dirty ,prev) - (explain-pause-top--command-entry-dirty ,current))))) + (state-to-fill new-item prev-item prev-drawn-item field-diffs cases) + "Generate a list of statements one for each field (car) of CASES, skipping +over nil cases, which compares the PREV and CURRENT values of that field. + +There are two kinds of CASES. + +When (car) is a symbol, eq is used to check prev-val and current-val, including +checking dirtiness equalness. If they are not equal, then if dirtiness equals, +the prev-string is used. Otherwise, the (cdr) is called to generate the new +string. + +When (car) is a list, then (cdr) of that list is used as the body, with no tests. +The body must return the value of the field-diff itself." + `(let* ((dirty (explain-pause-top--command-entry-dirty ,new-item)) + (prev-item-dirty (and ,prev-item + (explain-pause-top--command-entry-dirty ,prev-item))) + (prev-drawn-dirty (and ,prev-drawn-item + (explain-pause-top--command-entry-dirty ,prev-drawn-item)))) ,@(cl-loop for case in cases for index from 0 + when case collect - (let* ((field-name (car case)) + (let* ((test (car case)) (body (cdr case)) - (getter (intern (format "explain-pause-top--command-entry-%s" - field-name)))) - `(let ((field-val (,getter ,current))) - (if (and ,prev - dirty-equal - (eq (,getter ,prev) field-val)) - (setf (aref ,diffs ,index) nil) - (setf (aref ,diffs ,index) ,@body)) - (when ,prev - (setf (,getter ,prev) field-val))))))) - -(defmacro explain-pause-top--propertize-if-dirty (dirty str-expr) + (field-name (if (symbolp test) + test + (car test)))) + (if (not field-name) + ;; direct just body + `(setf (aref ,field-diffs ,index) ,@body) + ;; regular field logic + (let ((getter (intern (format "explain-pause-top--command-entry-%s" + field-name)))) + `(let ((field-val (,getter ,new-item))) + (setf (aref ,field-diffs ,index) + ,(cond + ((symbolp test) + ;; simple case + `(cond + ;; is it same as what's drawn? + ((and ,prev-item + (eq prev-item-dirty dirty) + (eq (,getter ,prev-item) field-val)) + ;; then we just need to copy + 'explain-pause-top--table-prev-item) + ;; is it the same as what was drawn earlier? + ((and ,prev-drawn-item + (eq prev-drawn-dirty dirty) + (eq (,getter ,prev-drawn-item) field-val)) + ;; then we just need to copy + 'explain-pause-top--table-prev-drawn) + ;; nope, we need to draw + (t + ,@body))) + (t + ;; custom case + `(let ((prev-val + (when ,prev-item + (,getter ,prev-item))) + (prev-drawn-val + (when ,prev-drawn-item + (,getter ,prev-drawn-item)))) + ,@(cdr test))))) + ;; copy the value + (setf (,getter ,state-to-fill) field-val)))))))) + +(defsubst explain-pause-top--propertize-if-dirty (dirty str-expr) "If DIRTY is true, generate a propertized STR-EXPR with explain-pause-top-changed face, otherwise just return STR-EXR" - `(if ,dirty - (propertize ,str-expr 'face 'explain-pause-top-changed) - ,str-expr)) + (if dirty + (propertize str-expr 'face 'explain-pause-top-changed) + str-expr)) + +(defun explain-profile-top--click-profile-report (button) + "Click-handler when profile BUTTON is clicked in event profile report view." + (let* ((profile (button-get button 'profile)) + (profile-buffer (profiler-report-setup-buffer profile))) + (funcall explain-pause-top-click-profile-action profile-buffer))) (defconst explain-pause-top--command-entry-headers ["Command" "slow" "avg ms" "ms" "calls"] "The header strings of a `explain-pause-top' table") -(defun explain-pause-top--command-entry-compare (prev-state new-state column-diffs) - "Update COLUMN-DIFFS, a vector, with the new strings or nil if nothing changed." - (let* ((dirty-state (explain-pause-top--command-entry-dirty new-state)) - (dirty (not (eq dirty-state nil)))) - (explain-pause-top--command-entry-column-fields-compare - prev-state new-state column-diffs - ((command-set - (explain-pause--command-set-as-string field-val)) - (slow-count - (let ((val-str (number-to-string field-val))) - (if (> field-val 0) - (if dirty - (propertize val-str 'face - '(explain-pause-top-slow explain-pause-top-changed)) - (propertize val-str 'face 'explain-pause-top-slow)) - (explain-pause-top--propertize-if-dirty dirty val-str)))) - (avg-ms - (explain-pause-top--propertize-if-dirty dirty (format "%.2f" field-val))) - (total-ms - (explain-pause-top--propertize-if-dirty dirty (number-to-string field-val))) - (count - (explain-pause-top--propertize-if-dirty dirty (number-to-string field-val))))) - - (if prev-state - (setf (explain-pause-top--command-entry-dirty prev-state) dirty-state) - (setq prev-state (copy-explain-pause-top--command-entry new-state))) - - (setf (explain-pause-top--command-entry-dirty new-state) nil) - - prev-state)) +(defconst explain-pause-top--single-profile-header + (propertize "\n ► Profile:" 'face 'explain-pause-top-profile-heading) + "The heading used when there is one profile available.") + +(defconst explain-pause-top--multiple-profile-header + (propertize "\n ► Last %d profiles:" 'face 'explain-pause-top-profile-heading) + "The heading used when there are multiple profiles available.") + +(defconst explain-pause-top--n/a-value -1 + "The sentinel value that means no value is available yet for this number field.") + +(defsubst explain-pause-top--value-or-n/a-default (input-value) + "Return INPUT-VALUE or 0 if it is n/a-value" + (if (eq input-value explain-pause-top--n/a-value) + 0 + input-value)) + +(defmacro explain-pause-top--value-or-n/a-string (input-value &rest body) + "If INPUT-VALUE is `explain-pause-top--n/a-value', return 'N/A' or otherwise +BODY" + `(if (eq ,input-value explain-pause-top--n/a-value) + "N/A" + ,@body)) + +(defun explain-pause-top--command-entry-compare + (state-to-fill new-item prev-item prev-drawn-item field-diffs) + "Update FIELD-DIFFS, a vector, with the new strings or where to copy if +nothing changed. Update STATE-TO-FILL, or create it if nil, with the new values +from NEW-ITEM. + +For every column, check to see if the value in PREV-ITEM matches NEW-ITEM. If it +is, set `prev-item'. If it is not, check to see if the value in +`prev-drawn-item' matches. If so, set `prev-drawn'. If not, finally generate a +new string. + +Values are considered the same only if their owning object dirtiness is also the +same." + (unless state-to-fill + (setq state-to-fill + (make-explain-pause-top--command-entry))) + + (explain-pause-top--command-entry-column-fields-compare + state-to-fill new-item prev-item prev-drawn-item field-diffs + (((command-set + ;; as the title doesn't change if it's dirty or not, ignore dirtiness + ;; TODO DRY with profile? + ;; TODO copy the 5 too and check nil in draw + (cond + ((and prev-item + (eq prev-val field-val)) + 'explain-pause-top--table-prev-item) + ((and prev-drawn-item + (eq prev-drawn-val field-val)) + 'explain-pause-top--table-prev-drawn) + (t + (explain-pause--command-set-as-string field-val))))) + (slow-count + (let ((val-str (number-to-string field-val))) + (if (> field-val 0) + (if dirty + (propertize val-str 'face + '(explain-pause-top-slow explain-pause-top-changed)) + (propertize val-str 'face 'explain-pause-top-slow)) + (explain-pause-top--propertize-if-dirty dirty val-str)))) + (avg-ms + (explain-pause-top--value-or-n/a-string + field-val + (explain-pause-top--propertize-if-dirty dirty (format "%.2f" field-val)))) + (total-ms + (explain-pause-top--value-or-n/a-string + field-val + (explain-pause-top--propertize-if-dirty dirty (number-to-string field-val)))) + (count + (explain-pause-top--value-or-n/a-string + field-val + (explain-pause-top--propertize-if-dirty dirty (number-to-string field-val)))) + (nil ;; cmd lines + ;; copy the value if we have it from previous / prev-drawn or else ask + ;; draw to generate it + (let ((cmd-diff (aref field-diffs 0))) + (if (or (eq cmd-diff 'explain-pause-top--table-prev-item) + (eq cmd-diff 'explain-pause-top--table-prev-drawn)) + cmd-diff + 'explain-pause-top--table-generate))) + ((profiles + ;; as the lists are different if any profile inside is changed, we don't need + ;; to account for dirtiness for this field. + (cond + ((and prev-item + (eq prev-val field-val)) + 'explain-pause-top--table-prev-item) + ((and prev-drawn-item + (eq prev-drawn-val field-val)) + 'explain-pause-top--table-prev-drawn) + (t + (when field-val + ;; ok, actually generate it: + (let ((count (length field-val))) + (cons + (if (eq count 1) + explain-pause-top--single-profile-header + (format + explain-pause-top--multiple-profile-header + count)) + ;;TODO stop making these every time dirty column + (mapcar (lambda (profile-info) + (make-text-button + (format "[%.2f ms]" (aref profile-info 0)) + nil + 'action #'explain-profile-top--click-profile-report + 'profile (aref profile-info 1))) + field-val)))))))))) + + ;; copy the dirtiness separately as it's not covered in the field set + (setf (explain-pause-top--command-entry-dirty state-to-fill) + (explain-pause-top--command-entry-dirty new-item)) + + ;; clear the actual entry's dirtiness for the next draw round + (setf (explain-pause-top--command-entry-dirty new-item) nil) + + state-to-fill) (defconst explain-pause-top--command-entry-sorters (vconcat @@ -1301,6 +1542,115 @@ explain-pause-top-changed face, otherwise just return STR-EXR" (slow-count avg-ms total-ms count)))) "The sorter functions for each column of a `explain-pause-top' table") +;; logging functions +(defun explain-pause-mode-change-alert-style (new-style) + "Change the alerting style to NEW-STYLE. Note that this does not change the +customizable variable `explain-pause-alert-style'. + +NEW-STYLE can be: +'developer, where all alerts are shown; +'normal, when alerts are shown when more then 5 have occurred, and not +within 15 minutes of the last time an alert was shown; or +'silent, aka never." + (let ((kinds + '((developer . explain-pause-mode--log-alert-developer) + (normal . explain-pause-mode--log-alert-normal)))) + (dolist (kind kinds) + (remove-hook 'explain-pause-measured-command-hook (cdr kind))) + + (let ((new-hook (assq new-style kinds))) + (when new-hook + (add-hook 'explain-pause-measured-command-hook (cdr new-hook)))))) + +(let ((notification-count 0) + (last-notified (current-time)) + (alert-timer nil)) + (defun explain-pause-mode--log-alert-normal (record) + "Notify the user of alerts when at least `explain-pause-alert-normal-minimum-count' +alerts have occurred, AND the time since the last notification (or startup) +is greater then `explain-pause-alert-normal-interval' minutes." + (when (and (not (explain-pause-command-record-native record)) + (explain-pause--command-record-slow-p record)) + (setq notification-count (1+ notification-count)) + (when (and (>= notification-count explain-pause-alert-normal-minimum-count) + (> (float-time (time-subtract nil last-notified)) + (* explain-pause-alert-normal-interval 60)) + (not alert-timer)) + (setq alert-timer + (run-with-idle-timer 1 nil + #'explain-pause-mode--log-alert-normal-display))))) + + (defun explain-pause-mode--log-alert-normal-display () + "Display the normal alert to the user but only if the minibuffer is not +active. If it is open, do nothing; at some point later, the conditions will +fire again and this timer will be called again." + (setq alert-timer nil) + ;; if we are not actively in the minibuffer, display our message + (when (not (minibufferp (current-buffer))) + (message "Emacs was slow %d times recently. Run `explain-pause-top' to learn more." notification-count) + (setq notification-count 0) + (setq last-notified (current-time))))) + +(let ((notifications '()) + (profiled-count 0) + (alert-timer nil)) + (defun explain-pause-mode--log-alert-developer (record) + "Log all slow and profiling alerts in developer mode. They are gathered until +run-with-idle-timer allows an idle timer to run, and then they are printed +to the minibuffer with a 2 second sit-for." + (unless (explain-pause-command-record-native record) + (let ((ms (explain-pause-command-record-executing-time record))) + (when (> ms explain-pause-slow-too-long-ms) + (push ms notifications) + (when (explain-pause-command-record-profile record) + (setq profiled-count (1+ profiled-count))) + (unless alert-timer + (setq alert-timer + (run-with-idle-timer + 0.5 nil + #'explain-pause-mode--log-alert-developer-display))))))) + + (defun explain-pause-mode--log-alert-developer-display () + "Display the last set of notifications in the echo area when the minibuffer is +not active." + (if (minibufferp (current-buffer)) + ;; try again + (setq alert-timer + (run-with-idle-timer 0.5 nil + #'explain-pause-mode--log-alert-developer-display)) + ;; ok, let's draw + (message "Emacs was slow: %s ms%s%s" + (mapconcat #'number-to-string notifications ", ") + (if (> profiled-count 0) + (format " of which %d were profiled" profiled-count) + "") + ". Run `explain-pause-top' to learn more.") + + ;; reset so more notifications can pile up while we wait + (setq notifications '()) + (setq profiled-count 0) + (sit-for 2) + (message nil) + ;; don't let us get rescheduled until we're really done. + (setq alert-timer nil)))) + +;; logging customization +;; depressingly can't define it at the top because `explain-pause-mode-change-alert-style' +;; isn't defined yet... +(defcustom explain-pause-alert-style 'normal + "How often should explain-pause alert you about slow pauses in the mini-buffer? + +Changing this value immediately adjusts the behavior. You can do this manually by +calling `explain-pause-mode-change-alert-style' directly if you wish. Note that +calling that function does not change this value." + :type '(choice (const :tag "Always" developer) + (const :tag "Every now and then" normal) + (const :tag "Never" silent)) + :group 'explain-pause + :set (lambda (symbol val) + (set-default symbol val) + (explain-pause-mode-change-alert-style val))) + ;; `explain-pause-top' major mode (define-derived-mode explain-pause-top-mode special-mode "Explain Pause Top" @@ -1325,9 +1675,14 @@ is made `explain-pause-top-mode', `explain-pause-mode' is also enabled." (setq-local explain-pause-top--buffer-statistics (make-hash-table :test 'equal)) - (explain-pause-top--table-set-headers + (explain-pause-top--table-initialize explain-pause-top--buffer-table - (copy-sequence explain-pause-top--command-entry-headers)) + (copy-sequence explain-pause-top--command-entry-headers) + ;; 3 extra slots + ;; - cmd main line + ;; - cmd extra lines + ;; - profile lines + (+ (length explain-pause-top--command-entry-headers) 3)) (setq-local explain-pause-top--sort-column nil) @@ -1354,35 +1709,51 @@ is made `explain-pause-top-mode', `explain-pause-mode' is also enabled." (setq-local explain-pause-top--buffer-command-pipe - (lambda (ms read-io-ms command-set was-profiled) - (let ((entry (gethash command-set this-commands nil)) - (this-slow-count (if (> ms explain-pause-slow-too-long-ms) 1 0))) - (if entry - ;; update. - (let* - ((old-count (explain-pause-top--command-entry-count entry)) - (old-ms (explain-pause-top--command-entry-total-ms entry)) - (slow-count (explain-pause-top--command-entry-slow-count entry)) - (new-count (1+ old-count)) - (new-slow-count (+ slow-count this-slow-count)) - (new-ms (+ ms old-ms)) - (new-avg (/ (float new-ms) (float new-count)))) - (setf (explain-pause-top--command-entry-count entry) new-count) - (setf (explain-pause-top--command-entry-slow-count entry) new-slow-count) - (setf (explain-pause-top--command-entry-total-ms entry) new-ms) - (setf (explain-pause-top--command-entry-avg-ms entry) new-avg) - (setf (explain-pause-top--command-entry-dirty entry) t)) - ;; new. - (puthash command-set (make-explain-pause-top--command-entry - :command-set command-set - :count 1 - :avg-ms ms - :total-ms ms - :slow-count this-slow-count - :dirty 'new) this-commands))))) + (lambda (record) + ;; ignore native frames for now - TODO + (unless (explain-pause-command-record-native record) + (let* ((ms (explain-pause-command-record-executing-time record)) + ;;TODO command-set list. + (command-set (list (explain-pause-command-record-command record))) + (entry (gethash command-set this-commands nil)) + (this-slow-count + (if (> ms explain-pause-slow-too-long-ms) 1 0)) + (profiles (aref (explain-pause-profile--get record) 1))) + (if entry + ;; update. + (let* + ((old-count + (explain-pause-top--value-or-n/a-default + (explain-pause-top--command-entry-count entry))) + (old-ms + (explain-pause-top--value-or-n/a-default + (explain-pause-top--command-entry-total-ms entry))) + (slow-count + (explain-pause-top--command-entry-slow-count entry)) + (new-count (1+ old-count)) + (new-slow-count (+ slow-count this-slow-count)) + (new-ms (+ ms old-ms)) + (new-avg (/ (float new-ms) (float new-count)))) + (setf (explain-pause-top--command-entry-count entry) new-count) + (setf (explain-pause-top--command-entry-slow-count entry) new-slow-count) + (setf (explain-pause-top--command-entry-total-ms entry) new-ms) + (setf (explain-pause-top--command-entry-avg-ms entry) new-avg) + (setf (explain-pause-top--command-entry-profiles entry) profiles) + (setf (explain-pause-top--command-entry-dirty entry) t)) + ;; new. + (setq entry (make-explain-pause-top--command-entry + :command-set command-set + :count 1 + :avg-ms ms + :total-ms ms + :slow-count this-slow-count + :dirty 'new + :profiles profiles))) + + (puthash command-set entry this-commands))))) (add-hook 'explain-pause-measured-command-hook - explain-pause-top--buffer-command-pipe)) + explain-pause-top--buffer-command-pipe t)) (add-hook 'window-size-change-functions explain-pause-top--buffer-window-size-changed) @@ -1402,6 +1773,25 @@ is made `explain-pause-top-mode', `explain-pause-mode' is also enabled." (unless explain-pause-mode (explain-pause-mode)) + ;; create entries for all slow profiles + (maphash (lambda (command statistic) + (let ((command-set (list command)) ;; TODO command-set list + (profiles (aref statistic 1))) + + (when profiles + (puthash command-set + (make-explain-pause-top--command-entry + :command-set command-set + :count explain-pause-top--n/a-value + ;; TODO we should improve this once we get slow ms list + :slow-count (length profiles) + :avg-ms explain-pause-top--n/a-value + :total-ms explain-pause-top--n/a-value + :dirty 'new + :profiles profiles) + explain-pause-top--buffer-statistics)))) + explain-pause-profile--profile-statistics) + ;; immediately ask for a resize: (funcall explain-pause-top--buffer-window-size-changed nil)) @@ -1425,40 +1815,90 @@ is made `explain-pause-top-mode', `explain-pause-mode' is also enabled." (defun explain-pause-top--buffer-reschedule-timer () "Reschedule the timer for this buffer if needed." - (when explain-pause-top--buffer-refresh-interval - ;; do not repeat any missed timers - (let ((timer-max-repeats 0)) - (setq-local explain-pause-top--buffer-refresh-timer - (run-with-timer explain-pause-top--buffer-refresh-interval - explain-pause-top--buffer-refresh-interval - #'explain-pause-top--buffer-refresh-with-buffer - (current-buffer)))))) + (when (and explain-pause-top--buffer-refresh-interval + (not explain-pause-top--buffer-refresh-timer)) + ;; manually reschedule timers so we don't get repeat reruns after delays + (setq-local explain-pause-top--buffer-refresh-timer + (run-with-timer explain-pause-top--buffer-refresh-interval + nil + #'explain-pause-top--buffer-refresh-handler + (current-buffer))))) + +(defun explain-pause-top--buffer-refresh-handler (buffer) + "Refresh the target BUFFER and reschedule the timer." + (with-current-buffer buffer + ;; clear the timer as we just ran + (setq-local explain-pause-top--buffer-refresh-timer nil) + (when explain-pause-log--send-process + (process-send-string + explain-pause-log--send-process + (format "enter w current buffer %s\n" + (current-time)))) + + (explain-pause-top--buffer-refresh) + (explain-pause-top--buffer-reschedule-timer))) (defun explain-pause-top--buffer-refresh-with-buffer (buffer) - "Refresh the target BUFFER" - (with-current-buffer buffer - (explain-pause-top--buffer-refresh))) + "Refresh the target BUFFER and reschedule the timer." + (with-current-buffer buffer + (explain-pause-top--buffer-refresh))) (defun explain-pause-top--buffer-refresh () "Refresh the current buffer - redraw the data at the current target-width" ;; first, insert all the items ;; TODO: is this slow? no documentation on cost of iteration - (maphash - (lambda (key item) - (let ((dirty (explain-pause-top--command-entry-dirty item))) - (cond - ((eq dirty 'new) - (explain-pause-top--table-insert explain-pause-top--buffer-table item)) - (dirty - (explain-pause-top--table-update explain-pause-top--buffer-table item))))) - explain-pause-top--buffer-statistics) + (when explain-pause-log--send-process + (process-send-string + explain-pause-log--send-process + (format "refresh enter %s\n" + (current-time)))) + + (let ((addcount 0) + (updatecount 0)) + (maphash + (lambda (_ item) + (let ((dirty (explain-pause-top--command-entry-dirty item))) + (cond + ((eq dirty 'new) + (explain-pause-top--table-insert explain-pause-top--buffer-table item) + (setq addcount (1+ addcount))) + (dirty + (explain-pause-top--table-update explain-pause-top--buffer-table item) + (setq updatecount (1+ updatecount)) + )))) + explain-pause-top--buffer-statistics) + (when explain-pause-log--send-process + (process-send-string + explain-pause-log--send-process + (format "finish map %s %d %d\n" (current-time) addcount updatecount)))) ;; It's possible a refresh timer ran before/after we calculated size, if so, ;; don't try to draw yet. (unless (eq (explain-pause-top--table-width explain-pause-top--buffer-table) 0) - (let ((inhibit-read-only t)) - (save-excursion - (explain-pause-top--table-refresh explain-pause-top--buffer-table))))) + (let ((inhibit-read-only t) + (point-in-entry (explain-pause-top--display-entry-from-point))) + (save-match-data + (when explain-pause-log--send-process + (process-send-string + explain-pause-log--send-process + (format "before refresh %s\n" + (current-time)))) + + (explain-pause-top--table-refresh explain-pause-top--buffer-table) + + ;; move the cursor back + (when point-in-entry + (goto-char (+ (explain-pause-top--table-display-entry-begin-mark + (car point-in-entry)) + (cdr point-in-entry)))) + + (when explain-pause-log--send-process + (process-send-string + explain-pause-log--send-process + (format "after refresh %s %s\n" + (current-time) + (memory-use-counts) + ))))))) (defun explain-pause-top--buffer-window-config-changed () "Buffer-local hook run when window config changed for a window showing @@ -1524,6 +1964,44 @@ the new header adjustment for COLUMN in DIRECTION." (setq-local explain-pause-top--sort-column column)) +(defun explain-pause-top--column-from-point () + "Calculate the column of the table from the current point in the current +buffer." + (let* ((column-offsets (explain-pause-top--table-display-column-offsets + explain-pause-top--buffer-table)) + (next-bigger-index (seq-position column-offsets (current-column) + #'>))) + (- (if next-bigger-index + next-bigger-index + (explain-pause-top--table-column-count + explain-pause-top--buffer-table)) + 1))) + +(defun explain-pause-top--display-entry-from-point () + "Return the display entry and relative offset left that point is within in the +current buffer or nil if it is not within any (this can only happen if there are +no entries at all)." + (let ((display-entry-ptr (cdr (explain-pause-top--table-display-entries + explain-pause-top--buffer-table))) + (search (point)) + (offset nil)) + + (catch 'found + (while display-entry-ptr + (setq offset (- search + (explain-pause-top--table-display-entry-begin-mark + (car display-entry-ptr)))) + (when (and (>= offset 0) + (<= offset + ;; account for the new line + (1+ (explain-pause-top--table-display-entry-total-length + (car display-entry-ptr))))) + (throw 'found (cons (car display-entry-ptr) offset))) + + (setq display-entry-ptr (cdr display-entry-ptr))) + + nil))) + (defun explain-pause-top-sort (buffer column &optional refresh) "Sort top table in the BUFFER using COLUMN, which is the 0-based index. Optionally, immediately refresh the buffer (causes a buffer switch). In @@ -1531,13 +2009,7 @@ interactive mode, sort the current buffer's column under point, and refreshes immediately. If the target buffer is not a `explain-pause-top' buffer, do nothing. Sorting the same column inverts the order." (interactive - (let* ((column-offsets (explain-pause-top--table-display-column-offsets - explain-pause-top--buffer-table)) - (next-bigger-index (seq-position column-offsets (current-column) - #'>)) - (next-column (if next-bigger-index next-bigger-index - (length column-offsets)))) - (list (current-buffer) (- next-column 1) t))) + (list (current-buffer) (explain-pause-top--column-from-point) t)) (when (eq (buffer-local-value 'major-mode buffer) 'explain-pause-top-mode) (let ((current-sorted (buffer-local-value 'explain-pause-top--sort-column buffer)) (table (buffer-local-value 'explain-pause-top--buffer-table buffer)) @@ -1644,264 +2116,786 @@ user to pick which one." (force-mode-line-update) - (when interval - (setq-local explain-pause-top--buffer-refresh-interval interval) - (explain-pause-top--buffer-reschedule-timer))))) - -;; command loop hooks -(defun explain--excluded-command-p (command-set) - "Should the COMMAND-SET be excluded from analysis?" - ;;TODO support some defcustom here - (equal '(suspend-frame) command-set)) - -(let - ;; the current command context we are measuring - ((executing-command nil) - (before-command-snap nil) - (before-buffer-list nil) - (read-for-wait 0) - ;; the command context that we were running when we entered each level of minibuffer - (mini-buffer-enter-stack '()) - (profiling-command nil)) - - (defun explain--command-loop-reset () - (setq executing-command nil) - (setq mini-buffer-enter-stack '()) - (when profiling-command - (profiler-cpu-stop) - (setq profiling-command nil))) - - (defun explain--start-profiling () - (setq profiling-command t) - (profiler-cpu-start explain-pause-profile-cpu-sampling-interval)) - - (defun explain--save-and-stop-profiling () - "Stop profiling and save the profile data" - ;; Note; it's a bug in the profile package that you can't call `profiler-cpu-profile' - ;; after stopping, even though the documentation states that you can. Directly call - ;; make-profile: - (profiler-cpu-stop) - (setq profiling-command nil) - (profiler-make-profile - :type 'cpu - :timestamp (current-time) - :log (profiler-cpu-log))) - - (defun explain--enter-command (commands) - "Set the context so we can start a new measurement loop. Does not affect - minibuffer context." - (setq executing-command commands) - (setq read-for-wait 0) - (when (explain--profile-p commands) - (explain--start-profiling)) - (setq before-command-snap (current-time))) - - (defun explain--exit-command (now-snap command-set) - "Finish running a measurement loop." - (let* ((diff (- (explain--as-ms-exact (time-subtract now-snap before-command-snap)) - read-for-wait)) - (excluded (explain--excluded-command-p command-set)) - (too-long (and (> diff explain-pause-slow-too-long-ms) - (not excluded))) - (was-profiled profiling-command)) - - (when was-profiled - (let ((profile (explain--save-and-stop-profiling))) - ;; only save the profile if it was worth it - (when too-long - (explain--store-profile now-snap diff command-set profile)))) - - (unless excluded - (run-hook-with-args 'explain-pause-measured-command-hook - diff read-for-wait command-set - (and was-profiled too-long))) - - (when (or too-long - explain-pause-log-all-input-loop) - (explain--log-pause diff read-for-wait command-set t - (seq-difference (buffer-list) before-buffer-list #'eq)) - - ;; only increment if it was actually too long, not if it was overriden - (when too-long - (explain--increment-profile command-set))))) - - (defun explain--pre-command-hook () - (setq before-buffer-list (buffer-list)) - (explain--enter-command (list real-this-command))) - - (defun explain--post-command-hook () - (when executing-command - (explain--exit-command (current-time) executing-command) - (setq executing-command nil))) - - (defun explain--enter-minibuffer () - (push executing-command mini-buffer-enter-stack)) - - (defun explain--exit-minibuffer () - ;; at the moment this hook is run, we have finished the actual "minibuffer" - ;; work, and whatever actually asked for this mini-buffer to get user input - ;; will run. - ;; 1. Treat everything up to now as belonging to the actual minibuffer - ;; 2. Treat everything after as a consequence of the selection - (let* - ((now-snap (current-time)) - ;; unforuntately, at this point, this-command is not yet updated :'( - ;; so there's no way to actually know what command is going to execute - ;; instead, steal the actual content from the minibuffer so it's useful - ;; special case when you quit the buffer as the minibuffer might contain - ;; non-completed entries. - (minibuffer-command (if (eq this-command 'minibuffer-keyboard-quit) - "from quitting minibuffer" - (format "from mini-buffer (`%s`)" - (explain-pause--sanitize-minibuffer - (minibuffer-contents-no-properties))))) - ;; pop off the command that started this minibuffer to begin with - (exiting-minibuffer-command (pop mini-buffer-enter-stack)) - (prev-command-set (cons real-this-command exiting-minibuffer-command)) - (next-command-set (cons minibuffer-command exiting-minibuffer-command))) - - (explain--exit-command now-snap prev-command-set) - (explain--enter-command next-command-set))) - - ;; it would be nice to wrap only the args, but we actually need to know exactly - ;; how long we waited for... - (defun explain--wrap-read-key-family (original-func &rest args) - "Advise read key family functions and measure how long we actually sat for. -Increment the current read-for-time with this value." - (let* ((before-snap (current-time)) - (return-value (apply original-func args)) - (diff (explain--as-ms-exact (time-subtract nil before-snap)))) - (setq read-for-wait (+ diff read-for-wait)) - return-value)) - - (defun explain--generate-command-set (head) - "Generate a new command-set based on the current executing command-set" - (cons head executing-command)) - - (defun explain--measure-function (measure-func args command-set diff-override) - "Execute the function with the arguments, measuring it's time and logging -if necessary. diff-override is a SYMBOL representing whether to log even if the -diff is less then the threshold." - ;; This function will still be called even if the mode is off if the callback - ;; was wrapped when the mode was on. check and exit if so: - (if (not explain-pause-mode) - (apply measure-func args) - ;; otherwise... - ;; push the original (bound) execution context as the current execution context - ;; around the run of the original callback. - ;; if executing-command is already set, we're inside a command-loop, and someone - ;; accept-process-output or sit-for'ed, which is why we need to save/restore - (let ((original-execution-command executing-command) - (was-profiled - ;; only profile if we were not already profiling - we could be inside - ;; a command already being profiled - ;; TODO somehow alert the user of this case? - (and (not profiling-command) - (explain--profile-p command-set)))) - (setq executing-command command-set) - - (when was-profiled - (explain--start-profiling)) - - (let ((before-snap (current-time))) - (apply measure-func args) - (let* ((now-snap (current-time)) - (diff (explain--as-ms-exact (time-subtract now-snap before-snap))) - (too-long (> diff explain-pause-slow-too-long-ms))) - - (when was-profiled - (let ((profile (explain--save-and-stop-profiling))) - (when too-long - (explain--store-profile now-snap diff command-set profile)))) - - (setq executing-command original-execution-command) - - (run-hook-with-args 'explain-pause-measured-command-hook - diff 0 command-set - (and was-profiled too-long)) - - (when (or too-long - (symbol-value diff-override)) - (explain--log-pause diff 0 command-set nil nil) - - (when too-long - (explain--increment-profile command-set))))))))) - -;; timer or process io hooks -(defun explain--generate-wrapper (command-set original-callback) - "Generate a wrapper for use in process wrappers. - -COMMAND-SET should describe the execution context when this wrapper was -generated. ORIGINAL-CALLBACK is the function to be wrapped." - (let ((final-command-set (cons original-callback command-set))) - (lambda (&rest callback-args) - (explain--measure-function original-callback - callback-args - final-command-set - 'explain-pause-log-all-process-io)))) - -(defun explain--measure-idle-timer-callback (original-cb &rest args) - "Wrap the callback of an idle timer ORIGINAL-CB, calling it with ARGS." - (explain--measure-function original-cb args - (cons original-cb (explain--generate-command-set 'idle-timer)) - 'explain-pause-log-all-timers)) - -(defun explain--measure-timer-callback (original-cb &rest args) - "Wrap the callback of a regular timer ORIGINAL-CB, calling it with ARGS." - (explain--measure-function original-cb args - (cons original-cb (explain--generate-command-set 'timer)) - 'explain-pause-log-all-timers)) - -(defun explain--wrap-make-process-sentinel-filter-callback (args) - "Wrap the sentinel and process arguments inside ARGS to `make-process', if any." - (let* ((original-filter (plist-get args :filter)) - (original-sentinel (plist-get args :sentinel)) + (setq-local explain-pause-top--buffer-refresh-interval interval) + (explain-pause-top--buffer-reschedule-timer)))) + + +(defcustom explain-pause-logging-default-log-location + (expand-file-name "explain-pause-log.socket" + temporary-file-directory) + "The default file location for the UNIX socket that is used to send or receive +logs. This is used when `explain-pause-log-to-socket' is given no parameter. +If you change this value, the filename you specify must be writable by Emacs." + :type 'string + :group 'explain-pause-logging) + +(defvar explain-pause-log--send-process nil + "The process used to send logs to the UNIX socket.") + +(defsubst explain-pause-log--send-command-entry (entry record) + "Send the fact that we are entering RECORD from ENTRY to the send pipe." + (when explain-pause-log--send-process + (process-send-string + explain-pause-log--send-process + (format "('enter %s %s %s %s %d)\n" + (current-time) + (explain-pause-command-record-command entry) + (explain-pause-command-record-command record) + (explain-pause-command-record-command + (explain-pause-command-record-parent record)) + (explain-pause-command-record-depth record))))) + +(defsubst explain-pause-log--send-profile-start (record) + "Send the fact that we are beginning profiling to the send pipe" + (when explain-pause-log--send-process + (process-send-string + explain-pause-log--send-process + (format "('profile-start %s %s %d)\n" + (current-time) + (explain-pause-command-record-command record) + (explain-pause-profile--count record))))) + +(defsubst explain-pause-log--send-profile-end (record) + "Send the fact that we are ending profiling to the send pipe" + (when explain-pause-log--send-process + (process-send-string + explain-pause-log--send-process + (format "('profile-end %s %s %s)\n" + (current-time) + (explain-pause-command-record-command record) + (not (eq (explain-pause-command-record-profile record) nil)))))) + +(defsubst explain-pause-log--send-command-exit (record) + "Send the fact that we have finished a record to the send pipes" + (when explain-pause-log--send-process + (process-send-string + explain-pause-log--send-process + (format "('exit %s %s %s %s)\n" + (current-time) + (explain-pause-command-record-command record) + (explain-pause-command-record-command + (explain-pause-command-record-parent record)) + (explain-pause-command-record-executing-time record))))) + +(defun explain-pause-log--send-measured-command (record) + (when explain-pause-log--send-process + ;; (process-send-string + ;; TODO + t)) + +;; advices for all the things +(defun explain-pause-report-measuring-bug (current-command test-command) + "Ask the user to report a bug when the frames do not match" + ;; turn off everything we can + (profiler-cpu-stop) + (explain-pause-mode -1) + + (let ((inhibit-message t)) + (message "frames do not match\ncurrent:\n%s\ntest:\n %s" + current-command + test-command)) + (debug)) ;; TODO, yes yes + +(defvar explain-pause--current-command-record nil + "The current command records representing what we are currently +executing. This value is changed when entering / exiting `call-interactively', +and when execution contexts switch, (e.g. timer <-> command loop).") + +;; most related actions here are inline subsitutions for performance reasons +(defsubst explain-pause--command-record-and-store (record) + "Calculate the time since entry-snap of RECORD and add it to executing-time." + (let ((so-far (explain-pause-command-record-executing-time record))) + (setf (explain-pause-command-record-executing-time record) + (+ so-far + (explain-pause--as-ms-exact + (time-subtract + (current-time) + (explain-pause-command-record-entry-snap record))))))) + +(defsubst explain-pause--command-record-start-profiling (record) + "Start profiling and record that in RECORD." + (explain-pause-log--send-profile-start record) + (setf (explain-pause-command-record-is-profiled record) t) + (setf (explain-pause-command-record-under-profile record) t) + (profiler-cpu-start explain-pause-profile-cpu-sampling-interval)) + +(defsubst explain-pause--command-record--save-and-stop-profiling (record) + "Stop profiling and save the profile data for RECORD." + ;; Note; it's a bug in the profile package that you can't call `profiler-cpu-profile' + ;; after stopping, even though the documentation states that you can. Directly call + ;; make-profile: + (profiler-cpu-stop) + ;; only bother saving the profile if it was slow: + (when (explain-pause--command-record-slow-p record) + (setf (explain-pause-command-record-profile record) + (profiler-make-profile + :type 'cpu + :timestamp (current-time) + :log (profiler-cpu-log)))) + (explain-pause-log--send-profile-end record)) + +(defsubst explain-pause--command-record-profile-p (record) + "Should the command-record RECORD be profiled, taking into account existing +profiling conditions and nativeness? Calls `explain-pause-profile--command-p' as +part of this determination." + (and (not (explain-pause-command-record-native record)) + (not (explain-pause-command-record-under-profile record)) + (explain-pause-profile--command-p record))) + +(defsubst explain-pause--command-record-from-parent + (current-command parent command &optional native) + "Make a new command record from PARENT, using COMMAND, calculating all the +other values correctly in CURRENT-COMMAND context. If NATIVE is set, mark the +frame as native." + (make-explain-pause-command-record + :command command + :parent parent + :native native + :under-profile + (explain-pause-command-record-under-profile current-command) + :depth + (1+ (explain-pause-command-record-depth parent)))) + +(defsubst explain-pause--check-not-top-level () + "Check that the `explain-pause--current-command-record' is not top level aka +`explain-pause-root-command-loop' and if it is, ask the user to report an error, +returning `nil' if so." + (if (eq explain-pause--current-command-record explain-pause-root-command-loop) + (progn + (explain-pause-report-measuring-bug + explain-pause--current-command-record + explain-pause-root-command-loop) + nil) + t)) + +(defmacro explain-pause--set-command-call (record form &rest body) + "Set `explain-pause--current-command-record' to RECORD and update it's +entry-snap to `current-time'. Profile if requested, around FORM with unwind +protect. After, pause-and-store the RECORD, and verify that +`explain-pause--current-command-record' is still RECORD. Run BODY if so, or +`explain-pause-report-measuring-bug' otherwise." + (declare (indent 1)) + `(progn + (explain-pause-log--send-command-entry + explain-pause--current-command-record + ,record) + (setq explain-pause--current-command-record ,record) + (let ((should-profile (explain-pause--command-record-profile-p ,record))) + (when should-profile + (explain-pause--command-record-start-profiling ,record)) + (setf (explain-pause-command-record-entry-snap ,record) (current-time)) + (unwind-protect + ,form + (explain-pause--command-record-and-store ,record) + (when should-profile + (explain-pause--command-record--save-and-stop-profiling ,record)) + (explain-pause-log--send-command-exit ,record) + (if (not (eq explain-pause--current-command-record ,record)) + (explain-pause-report-measuring-bug + explain-pause--current-command-record + ,record) + ,@body))))) + +(defmacro explain-pause--pause-call-unpause (new-record-form function-form) + "Pause current record; create a new record using NEW-RECORD-FORM; +`explain-pause--set-command-call' FUNCTION-FORM; run +`explain-pause-measured-command-hook'; unpause current record. `current-record' +is bound throughout as the current record." + `(let ((current-record explain-pause--current-command-record)) + (explain-pause--command-record-and-store current-record) + + (let ((new-frame ,new-record-form)) + (explain-pause--set-command-call + new-frame + ,function-form + + (run-hook-with-args 'explain-pause-measured-command-hook new-frame) + + (setf (explain-pause-command-record-entry-snap current-record) + (current-time)) + + (setq explain-pause--current-command-record current-record))))) + +(defsubst explain-pause--interactive-form-needs-frame-p (form) + "Calculate, as quickly as possible, whether this interactive form needs +a native frame." + ;; deliberately order p's first, then check for common forms, then do a + ;; expensive per character check. + + ;; TODO read the bytecode, is this actually fastest? should we use a `cond' + ;; maybe this should be a linear scanner? hypothetically this should be + ;; O(test string length but this is clearly O(N of test characters) + (and (not (equal form "p")) + (not (equal form "P")) + ;; found in emacs source code + (not (equal form "^p")) + (not (equal form "^P")) + (not (equal form "^p\np")) + (not (equal form "*p\nP")) + (not (equal form "P\np")) + (not (equal form "p\nP")) + (not (equal form "^e")) + (not (equal form "e\np")) + (not (equal form "*")) + ;; from `callint.c' + (not (equal form "d")) + (not (equal form "U")) + (not (equal form "e")) + (not (equal form "m")) + (not (equal form "i")) + (not (equal form "r")) + ;; ok, give up and check every character: + (progn + (let ((inhibit-message t)) + (message "form - %s" form)) + t)));; (not (and (equal form "N") + +;; `call-interactively' is never called from C code. It is called from +;; `command-execute', defined in `simple.el', which IS called from C code, from +;; `command_loop_1' and `read_char' (`keyboard.c'). +;; +;; Of course `call-interactively' is called from a bazillion places in elisp too. +;; +;; When the interactive form of a function is a string, `call-interactively' +;; will call the following: +;; completing read family: +;; * `Fread_variable' +;; * `Fread_non_nil_coding_system' -> calls `Fcompleting_read' +;; * `Fread_coding_system' -> calls `Fcompleting_read' +;; * `Fcompleting_read' -> calls elisp `completing-read-function' +;; buffer: +;; * `Fread_buffer' -> calls elisp `completing-read-function' OR `read-buffer-function' +;; char family - all wait and allow timers: +;; * `Fread_char' +;; * `Fread_key_sequence' +;; * `Fread_key_sequence_vector' +;; read_minibuf family: +;; * `read-minibuffer' (calls elisp which will call advised code) +;; * `Fread_string' (calls `recursive_edit') +;; directly to elisp: +;; * `read_file_name' -> calls elisp `read-file-name' +;; * `Qread_number' (calls elisp `read-number') +;; before calling `Qfuncall_interactively'. +;; +;; Therefore, we also advise `funcall-interactively', so we can get at the +;; time when that processing is complete. +;; +;; The call stack when this package is running looks like this: +;; +;; func +;; # +;; apply(# +;; funcall-interactively <- this is in the original call, unmolested so +;; so `called-interactive-p' can find it anyway +;; # +;; apply(# +;; ... +;; around(# +;; apply(around # +;; call-interactively +;; +;; Peek at the interactive spec. If it is a string, then we need to push a new +;; native frame to represent the time handling the interactive spec, see above +;; for the native functions that might be called. +;; +;; This replaces the original attempt at using `pre-command-hook' and +;; `post-command-hook', which cannot guarentee matching calls (any old elisp +;; could do something dumb). +(defun explain-pause--wrap-call-interactively (original-func &rest args) + "Advise call-interactively to track interactive execution costs and show them in +`explain-pause'." + (let ((parent explain-pause--current-command-record) + (target-function (car args)) + (command-frame nil) + (extra-frame nil)) + + (unless (eq parent explain-pause-root-command-loop) + (explain-pause--command-record-and-store parent)) + + ;; exclude some very special commands for performance reasons, even + ;; before doing a string check of their form. + ;; self-insert-command - spec 'P' - prefix + ;; newline - spec '*P\np' - prefix + ;; nextline, prevline - spec '^p\np' - prefix + ;; delete-forward-char - spec 'p\nP' - prefix + (unless (or (eq target-function #'self-insert-command) + (eq target-function #'newline) + (eq target-function #'next-line) + (eq target-function #'previous-line) + (eq target-function #'delete-forward-char)) + (let ((i-spec (cadr (interactive-form target-function)))) + (when (and (stringp i-spec) + (explain-pause--interactive-form-needs-frame-p i-spec)) + + ;; a bunch of native code will run. we need to push a new frame to + ;; represent that so that funcall-interactively can pop it correctly + ;; TODO how to handle completing-read / read-buffer-function? + (setq command-frame + (explain-pause--command-record-from-parent + parent + parent + 'call-interactively-interactive + t)) + + (setq extra-frame t)))) + + (unless extra-frame + ;; no fancy stuff, so regular frame: + (setq command-frame (explain-pause--command-record-from-parent + parent + parent + target-function))) + + ;; can't use set-command-call because we might have to pop two frames at once + + ;; enter command-frame + (explain-pause-log--send-command-entry parent command-frame) + (setq explain-pause--current-command-record command-frame) + (setf (explain-pause-command-record-entry-snap command-frame) (current-time)) + + ;; if we are regular frame, profile if needed + (when (and (not extra-frame) + (explain-pause--command-record-profile-p command-frame)) + (explain-pause--command-record-start-profiling command-frame)) + + (unwind-protect + (apply original-func args) + (let ((top-frame explain-pause--current-command-record)) + ;; if there is an extra frame, the top frame is the actual command-frame + (if extra-frame + ;; this frame should be a frame with the command = the entry cmd + (if (not (and (eq (explain-pause-command-record-command top-frame) + target-function) + (eq (explain-pause-command-record-parent top-frame) + command-frame))) + ;; uhoh + (explain-pause-report-measuring-bug + top-frame + target-function) ;; hm, TODO polymorphic type.. + + ;; top-frame = the real frame. exit: + + (explain-pause--command-record-and-store top-frame) + ;; if we profiled, save it: + (when (explain-pause-command-record-is-profiled top-frame) + (explain-pause--command-record--save-and-stop-profiling top-frame)) + (explain-pause-log--send-command-exit top-frame) + (run-hook-with-args 'explain-pause-measured-command-hook top-frame) + + ;; exit the parent frame (the command-frame from this function) + ;; since we don't bother restarting, we don't need to pause-and-store + (explain-pause-log--send-command-exit command-frame) + (run-hook-with-args 'explain-pause-measured-command-hook command-frame)) + ;; no extra-frame, top-frame = command-frame + (if (not (eq top-frame command-frame)) + (explain-pause-report-measuring-bug + top-frame + command-frame) + ;; exit command-frame: + (explain-pause--command-record-and-store command-frame) + ;; if we profiled, save it + (when (explain-pause-command-record-is-profiled command-frame) + (explain-pause--command-record--save-and-stop-profiling command-frame)) + (explain-pause-log--send-command-exit command-frame) + (run-hook-with-args 'explain-pause-measured-command-hook command-frame)))) + + ;; restart parent + (unless (eq parent explain-pause-root-command-loop) + (setf (explain-pause-command-record-entry-snap parent) (current-time))) + + (setq explain-pause--current-command-record parent)))) + +(defun explain-pause--before-funcall-interactively (&rest args) + "Run right before `funcall-interactively' so `explain-pause' can track how +much time the native code in `call-interatively' took." + ;; nothing stops someone from directly calling this function. + ;; Therefore check to see if the current-command-record is a native one + ;; that is called 'call-interactively-interactive + (let ((command (car args)) + (current-record explain-pause--current-command-record)) + (when (and current-record + (explain-pause-command-record-native current-record) + (eq (explain-pause-command-record-command current-record) + 'call-interactively-interactive)) + ;; then we satisfy and can push a new frame for the actual function + (explain-pause--command-record-and-store current-record) + + ;; enter the real one now, profiling if needed + (let ((real-frame + (explain-pause--command-record-from-parent + current-record + current-record + command))) + (explain-pause-log--send-command-entry current-record real-frame) + (setq explain-pause--current-command-record real-frame) + (when (explain-pause--command-record-profile-p real-frame) + (explain-pause--command-record-start-profiling real-frame)) + (setf (explain-pause-command-record-entry-snap real-frame) (current-time)))))) + +(defun explain-pause--wrap-native (original-func &rest args) + "Advise a native function. Insert a new native command record, so we can track +any calls back into elisp." + (when (explain-pause--check-not-top-level) + (explain-pause--pause-call-unpause + (explain-pause--command-record-from-parent + current-record + current-record + original-func + t) + (apply original-func args)))) + +(defun explain-pause--wrap-completing-read-family (original-func &rest args) + ;; read-command -> Fcompleting_read + ;; read-function -> Fcompleting_read + ;; read-variable -> Fcompleting_read - note called from `callint.c' + ;; `call_interactively' + + ;; completing-read -> functions COLLECTION, PREDICATE. + ;; directly calls elisp completing-read-function + ;; called from `w32fn.c', `x-file-dialog' + ;; called from `coding.c', `read-non-nil-coding-system', `read-coding-system' + ;; called from `callint.c', `call_interactively' + + ;; this entire family of functions just calls completing-read with maybe 3 + ;; lines of related C, and then `completing-read' just directly calls + ;; `completing-read-function'. + ;; don't bother creating a native frame for it. Instead create a regular + ;; frame for the `completing-read-function' _itself_ + (when (explain-pause--check-not-top-level) + (explain-pause--pause-call-unpause + (explain-pause--command-record-from-parent + current-record + current-record + completing-read-function) + (apply original-func args)))) + +(defun explain-pause--wrap-read-buffer (original-func &rest args) + "Wrap read-buffer in particular, as it calls one of two completion functions +depending on the arguments." + (when (explain-pause--check-not-top-level) + (explain-pause--pause-call-unpause + (explain-pause--command-record-from-parent + current-record + current-record + ;; read-buffer picks based on whether `read-buffer-function' is nil + (or read-buffer-function + completing-read-function)) + (apply original-func args)))) + +;; timer or process io hooks code +(defun explain-pause--wrap-callback + (parent-command-record original-cb &rest args) + "Wrap a callback, so that when THIS function is called, we call the original +callback with a new command record whose parent is PARENT-COMMAND-RECORD." + ;; This function will still be called even if the mode is off if the callback + ;; was wrapped when the mode was on. check and exit if so: + (if (not explain-pause-mode) + (apply original-cb args) + + ;; the parent represents where we came from, which may or may not have + ;; been profiled, but we are now executing in a new context - all wrappers + ;; are either timers, process, etc. + (explain-pause--pause-call-unpause + (explain-pause--command-record-from-parent + current-record + parent-command-record + original-cb) + (apply original-cb args)))) + +(defun explain-pause--generate-wrapper (parent-command-record original-callback) + "Generate a lambda wrapper for use when we cannot pass additional parameters +ala `run-with-timer', e.g. in `make-process' and co. + +PARENT-COMMAND-RECORD should describe the execution context when this wrapper +was generated. ORIGINAL-CALLBACK is the function to be wrapped." + (lambda (&rest callback-args) + (apply 'explain-pause--wrap-callback + parent-command-record + original-callback + callback-args))) + +(defun explain-pause--wrap-file-notify-add-watch (args) + "Advise that modifies the arguments ARGS to `file-notify-add-watch' by +wrapping the callback" + `(,@(seq-take args 2) + ,(explain-pause--generate-wrapper + (explain-pause--command-record-from-parent + explain-pause--current-command-record + explain-pause--current-command-record + 'file-notify + t) + (nth 2 args)))) + +(defun explain-pause--wrap-make-process (original-func &rest args) + "Wrap the sentinel and process arguments inside ARGS to `make-process', if +any." + ;; we are assuming make-process is fast enough not to subtract from current command. + (let* ((current-record explain-pause--current-command-record) + + (process-name (plist-get args :name)) + ;; this represents the process itself + (process-frame + (explain-pause--command-record-from-parent + current-record + current-record + process-name)) + + (original-filter (plist-get args :filter)) + (wrapped-filter (when original-filter - (explain--generate-wrapper (explain--generate-command-set 'process-filter) - original-filter))) + (explain-pause--generate-wrapper + (explain-pause--command-record-from-parent + process-frame + process-frame + 'process-filter) + original-filter))) + + (original-sentinel (plist-get args :sentinel)) (wrapped-sentinel (when original-sentinel - (explain--generate-wrapper (explain--generate-command-set 'sentinel-filter) - original-sentinel))) + (explain-pause--generate-wrapper + (explain-pause--command-record-from-parent + process-frame + process-frame + 'process-sentinel) + original-sentinel))) + (new-args (copy-sequence args))) + (when wrapped-filter (setq new-args (plist-put new-args :filter wrapped-filter))) (when original-sentinel (setq new-args (plist-put new-args :sentinel wrapped-sentinel))) - new-args)) -(defun explain--wrap-set-process-filter-callback (args) - "Advise that modifies the arguments ARGS to `process-filter' by wrapping the callback." + (let ((process (apply original-func new-args))) + (when process + ;; store the process frame in a process variable so later we can get at it + ;; for new filters + (process-put process 'explain-pause-process-frame process-frame)) + process))) + +(defun explain-pause--wrap-set-process-filter-callback (args) + "Advise that modifies the arguments ARGS to `process-filter' by wrapping the +callback." (seq-let [arg-process original-callback] args (if (not original-callback) args - (list arg-process - (explain--generate-wrapper (explain--generate-command-set 'process-filter) original-callback))))) - -(defun explain--wrap-set-process-sentinel-callback (args) - "Advise that modifies the arguments ARGS to `process-sentinel' by wrapping the callback." + (let ((process-frame (process-get arg-process 'explain-pause-process-frame))) + (list arg-process + (explain-pause--generate-wrapper + ;; the parent of the new record is the original process, NOT + ;; the caller + (explain-pause--command-record-from-parent + process-frame + process-frame + 'process-filter) + original-callback)))))) + +(defun explain-pause--wrap-set-process-sentinel-callback (args) + "Advise that modifies the arguments ARGS to `process-sentinel' by wrapping the +callback." (seq-let [arg-process original-callback] args (if (not original-callback) args - (list arg-process - (explain--generate-wrapper (explain--generate-command-set 'sentinel-filter) original-callback))))) - -(defun explain--wrap-idle-timer-callback (args) - "Advise that modifies the arguments ARGS to `run-with-idle-timer' by wrapping the callback." - (let ((original-callback (nth 2 args))) - ;; TODO this can be removed once we get sit-for calculated for timers (#31) - (if (eq original-callback #'explain-pause-mode--log-alert-developer-display) - args - (append (seq-take args 2) - (cons #'explain--measure-idle-timer-callback - (seq-drop args 2)))))) - -(defun explain--wrap-timer-callback (args) - "Advise that modifies the arguments ARGS to `run-with-timer' by wrapping the callback." - (append (seq-take args 2) - (cons #'explain--measure-timer-callback - (seq-drop args 2)))) + (let ((process-frame (process-get arg-process 'explain-pause-process-frame))) + (list arg-process + (explain-pause--generate-wrapper + ;; the parent of the new record is the original process, NOT + ;; the caller + (explain-pause--command-record-from-parent + process-frame + process-frame + 'process-sentinel) + original-callback)))))) + +(defconst explain-pause--timer-frame-max-depth 64 + "The maximum depth a record chain for a timer can get.") + +(defsubst explain-pause--generate-timer-parent (cb record kind) + "Generate either a new frame for this timer callback or reuse the parent frame +if the call is recursively to ourselves. + +The parent frame is only reused if it is a native frame of the right kind. In +`explain-pause--wrap-callback, the new frames uses the *current* frame at the +time of callback to decide whether profiling is on or not, so the state of +profiiling of the reused frame doesn't matter. + +If the depth is too high (larger then `explain-pause--timer-frame-max-depth' +rewind the stack to the first timer of the same kind and start from there +again. This works for timers because we never unwind the parent stack in wrapper +handler. If even after doing this the depth is too high, just reroot at +emacs root." + (or + (when (eq (explain-pause-command-record-command record) cb) + (let ((parent (explain-pause-command-record-parent record))) + (when (and parent + (explain-pause-command-record-native parent) + (eq (explain-pause-command-record-command parent) kind)) + parent))) + (when (> (explain-pause-command-record-depth record) + explain-pause--timer-frame-max-depth) + ;; walk back to the very first timer call + (let ((latest-best record) + (current record)) + (while current + (when (and (explain-pause-command-record-native current) + (eq (explain-pause-command-record-command current) + kind)) + (setq latest-best current)) + (setq current (explain-pause-command-record-parent current))) + + (if (> (explain-pause-command-record-depth latest-best) + explain-pause--timer-frame-max-depth) + ;; after all that, we're still too long?! + ;; just start from root: + (explain-pause--command-record-from-parent + record + explain-pause-root-command-loop + kind + t) + latest-best))) + (explain-pause--command-record-from-parent + record + record + kind + t))) + +(defun explain-pause--wrap-idle-timer-callback (args) + "Advise that modifies the arguments ARGS to `run-with-idle-timer' by wrapping +the callback." + `(,@(seq-take args 2) + explain-pause--wrap-callback + ;; make a new frame to represent the native timer, though we + ;; don't ever increment this frame + ,(explain-pause--generate-timer-parent + (nth 2 args) + explain-pause--current-command-record + 'idle-timer) + ,@(seq-drop args 2))) + +(defun explain-pause--wrap-timer-callback (args) + "Advise that modifies the arguments ARGS to `run-with-timer' by wrapping the +callback." + `(,@(seq-take args 2) + explain-pause--wrap-callback + ,(explain-pause--generate-timer-parent + (nth 2 args) + explain-pause--current-command-record + 'timer) + ,@(seq-drop args 2))) + +(let ((callback-family + '( + ;; these are functions who setup callbacks which can be wrapped. + (run-with-idle-timer . explain-pause--wrap-idle-timer-callback) + (run-with-timer . explain-pause--wrap-timer-callback) + (set-process-filter . explain-pause--wrap-set-process-filter-callback) + (set-process-sentinel . explain-pause--wrap-set-process-sentinel-callback))) + (make-process-family + ;; These C functions start async processes, which raise callbacks + ;; `filter' and `sentinel'. Wrap those. + '(make-process + make-pipe-process + make-network-process)) + (native + '( + ;; These C functions ultimately call `read_char' which will run timers, + ;; redisplay, and call `sit_for'. + read-key-sequence + read-key-sequence-vector + read-char + read-char-exclusive + read-event + ;; These C functions ultimately call `read_minibuf' which will call + ;; `recursive_edit' (in C), which means they will call + ;; `call-interactively' (which we have advised.) + ;; read-from-minibuffer -> read_minibuf + ;; read-string -> Fread_from_minibuffer -> read_minibuf + ;; read-no-blanks-input -> read_minibuf + read-from-minibuffer + read-string + read-no-blanks-input)) + (completing-read-family + '( + ;; These C functions ultimately call `completing_read' which will + ;; call `completing-read-function'. + read-command + read-function + read-variable + completing-read))) + + (defun explain-pause-mode--enable-hooks () + "Enable hooks for `explain-pause-mode' if it is being run at the top of the +emacs loop, e.g. not inside `call-interactively' or `sit-for' or any interleaved +timers, etc." + (if nil + (message "Unable to install `explain-pause-mode', please report a bug to \ +github.com/lastquestion/explain-pause-mode") + (let ((top-of-loop t)) + (mapbacktrace (lambda (_evaled func _args _flags) + (unless (eq func 'explain-pause-mode--enable-hooks) + (setq top-of-loop nil))) + #'explain-pause-mode--enable-hooks) + (when top-of-loop + (remove-hook 'post-command-hook #'explain-pause-mode--enable-hooks) + ;; ok, we're safe: + (advice-add 'call-interactively :around + #'explain-pause--wrap-call-interactively) + (advice-add 'funcall-interactively :before + #'explain-pause--before-funcall-interactively) + + ;; OK, we're prepared to advise native functions and timers: + (dolist (native-func native) + (advice-add native-func :around + #'explain-pause--wrap-native)) + + (dolist (completing-read-func completing-read-family) + (advice-add completing-read-func :around + #'explain-pause--wrap-completing-read-family)) + + (advice-add 'read-buffer :around #'explain-pause--wrap-read-buffer) + + (dolist (process-func make-process-family) + (advice-add process-func :around + #'explain-pause--wrap-make-process)) + + (dolist (callback-func callback-family) + (advice-add (car callback-func) :filter-args (cdr callback-func))) + + (advice-add 'file-notify-add-watch :filter-args + #'explain-pause--wrap-file-notify-add-watch) + + (setq explain-pause--current-command-record + explain-pause-root-command-loop))))) + + (defun explain-pause-mode--disable-hooks () + "Disable hooks installed by `explain-pause-mode--enable-hooks'." + (advice-remove 'file-notify-add-watch + #'explain-pause--wrap-file-notify-add-watch) + + (dolist (callback-func callback-family) + (advice-remove (car callback-func) (cdr callback-func))) + + (dolist (process-func make-process-family) + (advice-remove process-func + #'explain-pause--wrap-make-process)) + + (advice-remove 'read-buffer #'explain-pause--wrap-read-buffer) + + (dolist (completing-read-func completing-read-family) + (advice-remove completing-read-func + #'explain-pause--wrap-completing-read-family)) + + (dolist (native-func native) + (advice-remove native-func + #'explain-pause--wrap-native)) + + (advice-remove 'call-interactively + #'explain-pause--wrap-call-interactively) + + (advice-remove 'funcall-interactively + #'explain-pause--before-funcall-interactively))) ;;;###autoload (define-minor-mode explain-pause-mode @@ -1917,43 +2911,23 @@ When blocking work takes too long many times, explain-mode profiles the blocking work using the builtin Emacs profiler (`profiler' package). A fixed number of these are saved. -This mode hooks the command cycle, both idle and regular timers, and process -filters and sentinels." +This mode hooks `call-interactively', both idle and regular timers, and process +filters and sentinels. + +When running interactively, e.g. run from `M-x' or similar, `explain-pause-mode' +must install itself after some time while Emacs is not doing anything." :global t :init-value nil :lighter " explain-pause" :keymap nil - (let - ((hooks '((pre-command-hook . explain--pre-command-hook) - (post-command-hook . explain--post-command-hook) - (minibuffer-setup-hook . explain--enter-minibuffer) - (minibuffer-exit-hook . explain--exit-minibuffer))) - (advices '((run-with-idle-timer . explain--wrap-idle-timer-callback) - (run-with-timer . explain--wrap-timer-callback) - (set-process-filter . explain--wrap-set-process-filter-callback) - (set-process-sentinel . explain--wrap-set-process-sentinel-callback))) - (read-key-family '(read-key-sequence read-key-sequence-vector read-char - read-char-exclusive read-event))) + (cond (explain-pause-mode - (explain--command-loop-reset) - (dolist (hook hooks) - (add-hook (car hook) (cdr hook))) - (dolist (advice advices) - (advice-add (car advice) :filter-args (cdr advice))) - (dolist (read-key-func read-key-family) - (advice-add read-key-func :around #'explain--wrap-read-key-family)) - (dolist (func '(make-process make-pipe-process make-network-process)) - (advice-add func :filter-args #'explain--wrap-make-process-sentinel-filter-callback))) + ;; since we might be called inside a interactive function, we need to run + ;; this outside any command: + (add-hook 'post-command-hook #'explain-pause-mode--enable-hooks)) (t - (dolist (func '(make-process make-pipe-process make-network-process)) - (advice-remove func #'explain--wrap-make-process-sentinel-filter-callback)) - (dolist (read-key-func read-key-family) - (advice-remove read-key-func #'explain--wrap-read-key-family)) - (dolist (advice advices) - (advice-remove (car advice) (cdr advice))) - (dolist (hook hooks) - (remove-hook (car hook) (cdr hook))))))) + (explain-pause-mode--disable-hooks)))) ;;;###autoload (defun explain-pause-top () @@ -1966,6 +2940,46 @@ the buffer." (display-buffer buffer) buffer)) +;;;###autoload +(defun explain-pause-log-to-socket (&optional file-socket) + "Log the event stream to a UNIX file socket, FILE-SOCKET. If FILE-SOCKET is nil, +then the default location `explain-pause-default-log' is used. This file socket +should already exist. It might be created by `explain-pause-socket' in another +Emacs process, in which case `explain-mode-top-from-socket' will receive and +present that data. Or you can simply receive the data in any other process that +can create UNIX sockets, for example `netcat'.To turn off logging, run +`explain-pause-log-off'. + +The stream is written as newline delimited elisp readable lines. See +`explain-pause-log--send-*' family of commands for the format of those objects. + +Returns the process that is connected to the socket." + (interactive) + (unless file-socket + (setq file-socket explain-pause-logging-default-log-location)) + (when explain-pause-log--send-process + (explain-pause-log-off)) + (setq explain-pause-log--send-process + (make-network-process + :name "explain-pause-log-send" + :family 'local + :service file-socket + :type 'datagram)) + (add-hook 'explain-pause-measured-command-hook + #'explain-pause-log--send-measured-command) + explain-pause-log--send-process) + +(defun explain-pause-log-off () + "Turn off logging of the event stream." + (interactive) + (remove-hook 'explain-pause-measured-command-hook + #'explain-pause-log--send-measured-command) + (when explain-pause-log--send-process + (let ((save-process explain-pause-log--send-process)) + (setq explain-pause-log--send-process nil) + (delete-process save-process)))) + +(provide 'explain-pause-log-to-socket) (provide 'explain-pause-top) (provide 'explain-pause-mode) diff --git a/tests/test-command-logging.el b/tests/test-command-logging.el index cf91e4d..b26a791 100644 --- a/tests/test-command-logging.el +++ b/tests/test-command-logging.el @@ -86,16 +86,3 @@ '(foo bar)) :to-equal "foo, bar"))) - -(describe - "explain-pause--sanitize-minibuffer" - - (it "deletes extra normal spaces" - (expect (explain-pause--sanitize-minibuffer " fo g ") - :to-equal - " fo g ")) - - (it "deletes newlines and tabs" - (expect (explain-pause--sanitize-minibuffer "\nevil\twow\t\n\nso") - :to-equal - " evil wow so"))) diff --git a/tests/test-timers.el b/tests/test-timers.el new file mode 100644 index 0000000..185626f --- /dev/null +++ b/tests/test-timers.el @@ -0,0 +1,124 @@ +;;; -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Lin Xu + +;; Author: Lin Xu +;; Version: 0.1 +;; Created: May 18, 2020 +;; Keywords: performance speed config +;; URL: https://github.com/lastquestion/explain-pause-mode + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Test timer wrapper code. + +(describe + "explain-pause--generate-timer-parent" + + (it "returns a new frame in normal situations" + (let ((parent + (make-explain-pause-command-record + :command 'bar + :depth 0))) + (expect + (explain-pause--generate-timer-parent + 'foo + parent + 'timer) + :to-equal + (make-explain-pause-command-record + :command 'timer + :depth 1 + :parent parent + :native t)))) + + (it "reuses a frame in classic tail recursion" + (let* ((native + (make-explain-pause-command-record + :command 'timer + :native t + :depth 0)) + (parent + (make-explain-pause-command-record + :command 'bar + :depth 1 + :parent native))) + (expect + (explain-pause--generate-timer-parent + 'bar + parent + 'timer) + :to-equal + native))) + + (let* ((root + (make-explain-pause-command-record + :command 'root + :depth 0)) + (root-native + (make-explain-pause-command-record + :command 'timer + :native t + :parent root + :depth 1)) + (frame-1 + (make-explain-pause-command-record + :command 'bar + :depth 2 + :parent root-native)) + (child-native + (make-explain-pause-command-record + :command 'idle-timer + :parent frame-1 + :native t + :depth 3)) + (frame-2 + (make-explain-pause-command-record + :command 'foo + :parent child-native + :depth 4))) + + (it "cuts off the frames if frame length > max of the right kind" + (let ((explain-pause--timer-frame-max-depth 3)) + (expect + (explain-pause--generate-timer-parent + 'zaz + frame-2 + 'timer) + :to-equal + root-native) + + (expect + (explain-pause--generate-timer-parent + 'zaz + frame-2 + 'idle-timer) + :to-equal + child-native))) + + (it "cuts to emacs root if it can't find one that matches" + (let ((explain-pause--timer-frame-max-depth 1)) + (expect + (explain-pause--generate-timer-parent + 'zaz + frame-2 + 'idle-timer) + :to-equal + (make-explain-pause-command-record + :command 'idle-timer + :parent explain-pause-root-command-loop + :depth 1 + :native t)))))) diff --git a/tests/test-top.el b/tests/test-top.el index 18c4a90..816ab08 100644 --- a/tests/test-top.el +++ b/tests/test-top.el @@ -172,4 +172,52 @@ (expect (explain-pause-top--split-at-space "abcdef ghi" '(2 10)) :to-equal - '("a\\" "bcdef ghi")))) + '("a\\" "bcdef ghi"))) + + (it "splits multiple max-length exactly to max" + (expect + (explain-pause-top--split-at-space "abc 1234567" '(4 7)) + :to-equal + '("abc" "1234567")))) + +(describe + "explain-pause-top--concat-to-width" + + (it "adds with separator" + (expect + (explain-pause-top--concat-to-width + '("AA" "BB" "CCC" "DDDD") + 5 + "|") + :to-equal + "AA BB|CCC|DDDD")) + + (it "always adds one" + (expect + (explain-pause-top--concat-to-width + '("AAA" "BB" "CCCC" "D") + 2 + "|") + :to-equal + "AAA|BB|CCCC|D")) + + (it "always adds first item even if len is short" + (expect + (explain-pause-top--concat-to-width + '("AAAA" "B" "C" "D") + 3 + "|") + :to-equal + "AAAA|B C|D")) + + (it "returns empty for empty list" + (expect + (explain-pause-top--concat-to-width '() 5 "|") + :to-equal + "")) + + (it "works with one entry" + (expect + (explain-pause-top--concat-to-width '("A") 6 "|") + :to-equal + "A"))) From 07199a0a21769827e901dce50910f5e81dd1f523 Mon Sep 17 00:00:00 2001 From: Lin Xu Date: Tue, 23 Jun 2020 01:01:24 -0700 Subject: [PATCH 02/13] Add slow times and count to all statistics, improve memory performance 1. Update the profiling code to always store slow times and counts. 2. If a command is marked for profiling, but fails to actually save the profile, e.g. it isn't slow, for `explain-pause-profile-slow-threshold` times, reset the profiling request and start over. 3. Update the top UI to show slow times as a similar line as profiles. 4. Generally improve memory performance by hoisting lets out of tight loops if possible, and use closure globals for anything in the measurement hooks. Still more possible work here. --- explain-pause-mode.el | 741 +++++++++++++++++++++++++----------------- 1 file changed, 446 insertions(+), 295 deletions(-) diff --git a/explain-pause-mode.el b/explain-pause-mode.el index 4c643f2..a76df92 100644 --- a/explain-pause-mode.el +++ b/explain-pause-mode.el @@ -114,6 +114,11 @@ this will not clear statistics from individual `explain-top-mode' buffers." :type 'integer :group 'explain-pause-profiling) +(defcustom explain-pause-profile-enabled t + "Should explain-pause profile slow activities at all?" + :type 'boolean + :group 'explain-pause-profiling) + ;; public hooks (defvar explain-pause-measured-command-hook nil "Functions(s) to call after a command has been measured. The functions are @@ -123,6 +128,8 @@ These commands must be fast, because this hook is executed on every command, not just slow commands. You cannot give up execution in these commands in any way, e.g. do not call any family of functions that `sit-for', `read-key', etc. etc.") +(add-hook 'explain-pause-measured-command-hook + #'explain-pause-profile--profile-measured-command) ;; custom faces (defface explain-pause-top-slow @@ -137,6 +144,12 @@ etc. etc.") profiles available to view." :group 'explain-pause-top) +(defface explain-pause-top-slow-heading + '((t (:inherit warning))) + "The face used to highlight the slow times heading for commands which have +slow times." + :group 'explain-pause-top) + (defface explain-pause-top-changed '((t (:inherit bold))) "The face used to indicate that a value changed since the last refresh of the @@ -229,13 +242,71 @@ blocking execution (or we think so, anyway)." #'explain-pause--command-as-string command-set ", ")) -;; profiling functions +;; profiling and slow statistics functions ;; TODO :equal list command (defvar explain-pause-profile--profile-statistics (make-hash-table) - "A hash map of the slow commands and their profiles and profile statistics only. - -This data is always gathered and stored when `explain-pause-mode' is active and -`explain-pause-profile-enabled' is true.") + "A hash map of the slow commands and their statistics. + +This data is always gathered and stored when `explain-pause-mode' is +active. When `explain-pause-profile-enabled' is true, profiling logs are also +stored. Each entry is a VECTOR of values. In an effort to optimize memory +allocations, store the slow counts inline with the rest of the object +instead of using a cl-struct with a field of a vector.") + +(defconst explain-pause-profile--statistic-defaults + [0 ;; profile-counter + nil ;; should-profile-next + 0 ;; profile-attempts + nil ;; list-of-profiles + 0 ;; slow-count + nil];; slow-ms-idx + "A constant vector of defaults used when upset to the statistics hashmap is +cnot required.") + +(defconst explain-pause-profile--statistic-slow-count-offset + 6 + "The offset into the vector of statistic where the first slow ms is found.") + +(defsubst explain-pause-profile--statistic-slow-length (statistic) + "Return the number of slow counts available in this STATISTIC" + (- (length statistic) + explain-pause-profile--statistic-slow-count-offset)) + +(defsubst explain-pause-profile--statistic-profile-p (record) + "Whether the command represented by RECORD should be profiled. Does not create +a new entry if the command has not been seen; in that case, returns nil." + (aref (gethash (explain-pause-command-record-command record) + explain-pause-profile--profile-statistics + explain-pause-profile--statistic-defaults) + 1)) + +(defsubst explain-pause-profile--statistic-profiles (record) + "Get the profiles for a command represented by RECORD." + (aref (gethash (explain-pause-command-record-command record) + explain-pause-profile--profile-statistics + explain-pause-profile--statistic-defaults) + 3)) + +(defsubst explain-pause-profile--statistic-profile-attempts (record) + "Get the attempts to profile for a command represented by RECORD." + (aref (gethash (explain-pause-command-record-command record) + explain-pause-profile--profile-statistics + explain-pause-profile--statistic-defaults) + 2)) + +(defsubst explain-pause-profile--statistic-slow-index (record) + "Get the current index of the circular list of slow times in RECORD." + (aref (gethash (explain-pause-command-record-command record) + explain-pause-profile--profile-statistics + explain-pause-profile--statistic-defaults) + 5)) + +(defsubst explain-pause-profile--statistic-slow-count (record) + "Get the current index of the circular list of slow times in RECORD." + (aref (gethash (explain-pause-command-record-command record) + explain-pause-profile--profile-statistics + explain-pause-profile--statistic-defaults) + 4)) (defun explain-pause-profile-clear () "Clear the profiling data. Note that this does not clear profiles already visible @@ -248,93 +319,105 @@ in any `explain-pause-top' buffers." ;;TODO (interactive) t) -(defsubst explain-pause-profile--count (record) - "Get the count stored for command RECORD from the profile statistics. - -This could be nil if the record has never been seen; -1 if the command has been -set to MUST profile; otherwise a integer value representing how many times it -has been slow." - (let* ((command (explain-pause-command-record-command record)) - (statistic (gethash command explain-pause-profile--profile-statistics nil))) - (when statistic (aref statistic 0)))) - -(defsubst explain-pause-profile--get (record) - "Return the statistics for RECORD, which will be mutated over time. If the -RECORD has never been seen before, this creates a new statistic for it." - (let* ((command (explain-pause-command-record-command record)) - (statistic (gethash command - explain-pause-profile--profile-statistics - nil))) - (unless statistic - (setq statistic (vector 0 nil)) - (puthash command statistic explain-pause-profile--profile-statistics)) - - statistic)) - -(defun explain-pause-profile--command-p (record) - "Should the command in RECORD be profiled?" - ;; TODO should we make this a subst for performance reasons? It runs in every - ;; command invocation... - (let ((count (explain-pause-profile--count record))) - (and count - (or (eq count -1) ;;forced - (>= count explain-pause-profile-slow-threshold))))) - -(defun explain-pause-profile--profile-measured-command (record) - "Record the statistics for this command so we know whether to profile it later. -Store the profile if the record was profiled." - (unless (explain-pause-command-record-native record) - (let ((ms (explain-pause-command-record-executing-time record))) - (when (> ms explain-pause-slow-too-long-ms) - (let* ((profile (explain-pause-command-record-profile record)) - (statistic (explain-pause-profile--get record)) - (count (aref statistic 0))) - - (cond - ;; add the profile if it exists. - ;; we assume that profiles happen relatively rarely, so use - ;; a list so that 'eq comparisons work against head: - (profile - (let* ((head (aref statistic 1)) - (profiles-length (length head)) - (new-entry (vector ms profile))) - - (setf (aref statistic 1) - (if (< profiles-length explain-pause-profile-saved-profiles) - (cons new-entry head) - ;; need to make a duplicate list - (cons new-entry - (seq-take head - (- explain-pause-profile-saved-profiles 1)))))) - - ;; don't forget to clear out the count - (setf (aref statistic 0) 0)) - ((>= count 0) ;; only increment for "non-special" counts - (setf (aref statistic 0) (1+ count))))))))) - -(defun explain-pause-profile-enable (enable) - "Disable profiling if ENABLE is nil, enable otherwise. Disabling or enabling -profiling does not remove existing profiles or profile statistics." - (cond - (enable - (add-hook 'explain-pause-measured-command-hook - #'explain-pause-profile--profile-measured-command)) - (t - (remove-hook 'explain-pause-measured-command-hook - #'explain-pause-profile--profile-measured-command) - t))) - -(defcustom explain-pause-profile-enabled t - "Should explain-pause profile slow activities at all? +(defmacro explain-pause-profile--profile-get-statistic (record) + ;; define this as a macro because a defsubst cannot inline before the owning + ;; let has finished (e.g. this can't be inside the next closure and be used + ;; in `explain-pause-profile--profile-measured-command' + `(progn + (setq command (explain-pause-command-record-command ,record)) + (setq statistic (gethash command explain-pause-profile--profile-statistics nil)) + + (unless statistic + (setq statistic (make-vector + (+ explain-pause-profile--statistic-slow-count-offset + explain-pause-profile-saved-profiles) + nil)) + (cl-loop + for new-stat across-ref statistic + for default-stat across explain-pause-profile--statistic-defaults + do + (setf new-stat default-stat)) + (puthash command statistic explain-pause-profile--profile-statistics)))) + +(let ((profile nil) + (statistic nil) + (command nil) + (slow-index nil)) + ;; for the mainline case, no profiles are stored but values are incremented + ;; store these outside in a closure, so we don't need to create lets every call. + (defun explain-pause-profile--profile-measured-command (record) + "Record the statistics for this command. + +Always store the slowness. If profiling is on, store the profiling counts. +Store the profile if it was profiled." + (unless (explain-pause-command-record-native record) + (cond + ;; did we try to profile but it was too fast? if this happens more + ;; then threshold times, reset the counter back to 0 + ((and (explain-pause-command-record-is-profiled record) + (not (explain-pause-command-record-too-slow record))) + + (explain-pause-profile--profile-get-statistic record) + + ;; reuse profile var for attempt counter + (setq profile (aref statistic 2)) + (if (< profile explain-pause-profile-saved-profiles) + (setf (aref statistic 2) (1+ profile)) + ;; give up TODO force? + (setf (aref statistic 0) 0) + (setf (aref statistic 1) nil) + (setf (aref statistic 2) 0))) + + ((explain-pause-command-record-too-slow record) + ;; otherwise, if we're too slow... + (explain-pause-profile--profile-get-statistic record) + (setq profile (explain-pause-command-record-profile record)) + + ;; increment the slow count + (setf (aref statistic 4) (1+ (aref statistic 4))) + + ;; save the ms into the circular list + (setq slow-index (or (aref statistic 5) 0)) + (setf (aref statistic (+ slow-index + explain-pause-profile--statistic-slow-count-offset)) + (explain-pause-command-record-executing-time record)) + ;; increment slow-ms-index to the next place + (setf (aref statistic 5) + (% (1+ slow-index) + ;; don't use `explain-pause-profile-saved-profiles' because the value + ;; might have changed + (explain-pause-profile--statistic-slow-length statistic))) -Changing this immediately adjusts the behavior. You can do this manually by -calling `explain-pause-profile-enable' directly. Note that calling that -function does not change this value." - :type 'boolean - :group 'explain-pause-profiling - :set (lambda (symbol val) - (set-default symbol val) - (explain-pause-profile-enable val))) + (cond + ;; add the profile if it exists. + ;; we assume that profiles happen relatively rarely, so it's ok to use + ;; a list so that 'eq comparisons work against head: + (profile + (let ((head (aref statistic 3)) + (new-entry (vector + (explain-pause-command-record-executing-time record) + profile))) + + (setf (aref statistic 3) + (if (< (length head) + explain-pause-profile-saved-profiles) + (cons new-entry head) + ;; need to make a duplicate list + (cons new-entry + (seq-take head + (- explain-pause-profile-saved-profiles 1)))))) + + ;; reset for next time + (setf (aref statistic 0) 0) + (setf (aref statistic 1) nil)) + (t + ;; reuse profile var for the counter here + (setq profile (aref statistic 0)) + (when (>= profile 0) ;; only increment for "non-special" counts + (setq profile (1+ profile)) + (setf (aref statistic 0) profile) + (setf (aref statistic 1) + (>= profile explain-pause-profile-slow-threshold)))))))))) ;; table functions ;; I tried to use `tabulated-list' as well as `ewoc' but I decided to implement @@ -883,7 +966,8 @@ hold the difference of fields." "Refresh the table of items in the current buffer when requested. Note that the width cannot be 0." ;; this is relatively optimized never to allocate memory unless absolutely - ;; needed. + ;; needed. it tries to hoist lets out of tight loops and generally + ;; preallocates memory in table-initialize. ;; ;; first, calculate the widths of all the columns. ;; To do this, now walk through all the entries, updating their current @@ -933,31 +1017,34 @@ the width cannot be 0." ;; ok, now reconcile & add new items ;; prev points to the end now - (let ((new-list-entry nil) - (new-entry nil)) - (while display-order-ptr - (setq new-entry - (make-explain-pause-top--table-display-entry - :begin-mark nil - :total-length nil - :buffer (make-vector (* 2 buffer-width) nil) - :dirty-fields (make-vector field-count nil))) - (setq new-list-entry (cons new-entry nil)) - - (explain-pause-top--table-prepare-draw - new-entry - (car display-order-ptr) - buffer-index - prev-buffer-index - column-count - field-count - requested-widths - current-diffs) - - ;; insert at the tail - (setcdr display-entries-prev new-list-entry) - (setq display-entries-prev new-list-entry) - (setq display-order-ptr (cdr display-order-ptr)))) + ;; most of the time, we don't need to add new items, so + ;; check before letting: + (when display-order-ptr + (let ((new-list-entry nil) + (new-entry nil)) + (while display-order-ptr + (setq new-entry + (make-explain-pause-top--table-display-entry + :begin-mark nil + :total-length nil + :buffer (make-vector (* 2 buffer-width) nil) + :dirty-fields (make-vector field-count nil))) + (setq new-list-entry (cons new-entry nil)) + + (explain-pause-top--table-prepare-draw + new-entry + (car display-order-ptr) + buffer-index + prev-buffer-index + column-count + field-count + requested-widths + current-diffs) + + ;; insert at the tail + (setcdr display-entries-prev new-list-entry) + (setq display-entries-prev new-list-entry) + (setq display-order-ptr (cdr display-order-ptr))))) ;; at this point, the following invariants hold: ;; * every entry has a display-entry (but not all of them have begin-marks) @@ -973,13 +1060,6 @@ the width cannot be 0." :start2 1 :test 'eq)) - (when explain-pause-log--send-process - (process-send-string - explain-pause-log--send-process - (format "widths changed %s %s\n" - requested-widths - (explain-pause-top--table-column-widths table)))) - ;; if they are not equal, update the header, format strings, etc. (explain-pause-top--table-resize-columns table @@ -1060,11 +1140,18 @@ the width cannot be 0." (first-command-str (or (car cmd-lines) command-str)) - (profile-lines (aref buffer (+ buffer-value-index 6))) + (slow-lines (aref buffer (+ buffer-value-index 6))) + (profile-lines (aref buffer (+ buffer-value-index 7))) (extra-lines (concat (cdr cmd-lines) - ;;TODO special profile handling here + ;;TODO clean up multiline handling + ;;TODO stop regenerating this every time (?) + (when slow-lines + (explain-pause-top--concat-to-width + slow-lines + table-width + "\n ")) (when profile-lines (explain-pause-top--concat-to-width profile-lines @@ -1086,7 +1173,7 @@ the width cannot be 0." extra-lines))) ;; store the cached cmd-lines - ;; TODO + ;; TODO cmd line magic (setf (aref buffer (+ buffer-value-index 5)) cmd-lines) ;; go to the beginning of our region @@ -1153,15 +1240,23 @@ the width cannot be 0." (delete-char (length new-str)) (insert new-str))))))) - ;; now deal with extra lines. only bother if either of the two - ;; columns are dirty. + ;; now deal with extra lines. only bother if at least is dirty. (when (or (aref dirty-fields 0) - (aref dirty-fields 6)) + (aref dirty-fields 6) + (aref dirty-fields 7)) (let* ((extra-cmd-lines - (cdr (aref buffer (+ buffer-value-index 5)))) ;; TODO - (profile-lines (aref buffer (+ buffer-value-index 6))) + (cdr (aref buffer (+ buffer-value-index 5)))) ;; TODO cmd handling + ;; TODO multline handling + (slow-lines (aref buffer (+ buffer-value-index 6))) + (profile-lines (aref buffer (+ buffer-value-index 7))) (extra-lines + ;; TODO dry with full line gen? (concat extra-cmd-lines + (when slow-lines + (explain-pause-top--concat-to-width + slow-lines + table-width + "\n ")) (when profile-lines (explain-pause-top--concat-to-width profile-lines @@ -1219,6 +1314,8 @@ the width cannot be 0." (executing-time 0) ;; a TIME object as snap entry-snap + ;; was this too slow + too-slow ;; profiling: ;; was profiling was started FOR this command @@ -1231,11 +1328,6 @@ the width cannot be 0." ;; depth of the callstack so far depth) -(defsubst explain-pause--command-record-slow-p (record) - "Is the record slow, e.g. longer then `explain-pause-slow-too-long-ms'?" - (> (explain-pause-command-record-executing-time record) - explain-pause-slow-too-long-ms)) - (defconst explain-pause-root-command-loop (make-explain-pause-command-record :command 'root-emacs @@ -1287,6 +1379,8 @@ to watch for resizes.") total-ms ;; either nil for no, t for yes, 'new for yes and new. dirty + ;; index into the slow circular list + slow-index ;; pointer to the profiles profiles) @@ -1416,9 +1510,20 @@ explain-pause-top-changed face, otherwise just return STR-EXR" "The heading used when there is one profile available.") (defconst explain-pause-top--multiple-profile-header - (propertize "\n ► Last %d profiles:" 'face 'explain-pause-top-profile-heading) + ;; these strings ought to be propertized, but format does not work correctly + ;; for multibyte strings in emacs <27 (bug#38191). propertize after format + ;; instead. + "\n ► Last %d profiles:" "The heading used when there are multiple profiles available.") +(defconst explain-pause-top--single-slow-header + (propertize "\n ► Slow:" 'face 'explain-pause-top-slow-heading) + "The heading used when there is one slow time available.") + +(defconst explain-pause-top--multiple-slow-header + "\n ► Last %d slow:" + "The heading used when there are multiple slow times available.") + (defconst explain-pause-top--n/a-value -1 "The sentinel value that means no value is available yet for this number field.") @@ -1495,10 +1600,65 @@ same." (eq cmd-diff 'explain-pause-top--table-prev-drawn)) cmd-diff 'explain-pause-top--table-generate))) + ((slow-index ;; slow ms + ;; dirtiness doesn't matter, but the index PLUS object must be the same + ;; nil represents no results + (cond + ((not field-val) + nil) + ((and prev-item + (eq prev-val field-val) + (eq (aref field-diffs 0) 'explain-pause-top--table-prev-item)) + 'explain-pause-top--table-prev-item) + ((and prev-drawn-item + (eq prev-drawn-val field-val) + (eq (aref field-diffs 0) 'explain-pause-top--table-prev-drawn)) + 'explain-pause-top--table-prev-drawn) + (t + ;; TODO directly using cmd ... hm :/ + ;; TODO command-list + ;; the circular list's "next" place is at field-val aka slow-index. + ;; this represents the very oldest item, so we can build the list in + ;; reverse by walking forwards in the circular list. + (let* ((statistics + (gethash (car (explain-pause-top--command-entry-command-set new-item)) + explain-pause-profile--profile-statistics)) + (size (explain-pause-profile--statistic-slow-length statistics)) + (items-length 0) + (items (cons "ms" nil)) + (index field-val) + (slot nil)) + + (cl-loop + do + (setq slot (aref statistics + (+ explain-pause-profile--statistic-slow-count-offset + index))) + (when slot + (setq items (cons (format + (if (eq items-length 0) + "%s" ;; no comma for the last (aka first) + "%s,") + slot) + items)) + (setq items-length (1+ items-length))) + (setq index (% (+ index 1) size)) + until (eq index field-val)) + + (cons + (if (eq items-length 1) + explain-pause-top--single-slow-header + ;; emacs bug #38191, <27 + (propertize + (format explain-pause-top--multiple-slow-header items-length) + 'face 'explain-pause-top-slow-heading)) + items)))))) ((profiles ;; as the lists are different if any profile inside is changed, we don't need ;; to account for dirtiness for this field. (cond + ((not field-val) + nil) ((and prev-item (eq prev-val field-val)) 'explain-pause-top--table-prev-item) @@ -1506,23 +1666,23 @@ same." (eq prev-drawn-val field-val)) 'explain-pause-top--table-prev-drawn) (t - (when field-val - ;; ok, actually generate it: - (let ((count (length field-val))) - (cons - (if (eq count 1) - explain-pause-top--single-profile-header - (format - explain-pause-top--multiple-profile-header - count)) - ;;TODO stop making these every time dirty column - (mapcar (lambda (profile-info) - (make-text-button - (format "[%.2f ms]" (aref profile-info 0)) - nil - 'action #'explain-profile-top--click-profile-report - 'profile (aref profile-info 1))) - field-val)))))))))) + ;; ok, actually generate it: + (let ((count (length field-val))) + (cons + (if (eq count 1) + explain-pause-top--single-profile-header + ;; emacs bug #38191, <27 + (propertize + (format explain-pause-top--multiple-profile-header count) + 'face 'explain-pause-top-profile-heading)) + ;;TODO stop making these every time dirty column + (mapcar (lambda (profile-info) + (make-text-button + (format "[%.2f ms]" (aref profile-info 0)) + nil + 'action #'explain-profile-top--click-profile-report + 'profile (aref profile-info 1))) + field-val))))))))) ;; copy the dirtiness separately as it's not covered in the field set (setf (explain-pause-top--command-entry-dirty state-to-fill) @@ -1570,7 +1730,7 @@ within 15 minutes of the last time an alert was shown; or alerts have occurred, AND the time since the last notification (or startup) is greater then `explain-pause-alert-normal-interval' minutes." (when (and (not (explain-pause-command-record-native record)) - (explain-pause--command-record-slow-p record)) + (explain-pause-command-record-too-slow record)) (setq notification-count (1+ notification-count)) (when (and (>= notification-count explain-pause-alert-normal-minimum-count) (> (float-time (time-subtract nil last-notified)) @@ -1598,17 +1758,16 @@ fire again and this timer will be called again." "Log all slow and profiling alerts in developer mode. They are gathered until run-with-idle-timer allows an idle timer to run, and then they are printed to the minibuffer with a 2 second sit-for." - (unless (explain-pause-command-record-native record) - (let ((ms (explain-pause-command-record-executing-time record))) - (when (> ms explain-pause-slow-too-long-ms) - (push ms notifications) - (when (explain-pause-command-record-profile record) - (setq profiled-count (1+ profiled-count))) - (unless alert-timer - (setq alert-timer - (run-with-idle-timer - 0.5 nil - #'explain-pause-mode--log-alert-developer-display))))))) + (when (and (not (explain-pause-command-record-native record)) + (explain-pause-command-record-too-slow record)) + (push (explain-pause-command-record-executing-time record) notifications) + (when (explain-pause-command-record-profile record) + (setq profiled-count (1+ profiled-count))) + (unless alert-timer + (setq alert-timer + (run-with-idle-timer + 0.5 nil + #'explain-pause-mode--log-alert-developer-display))))) (defun explain-pause-mode--log-alert-developer-display () "Display the last set of notifications in the echo area when the minibuffer is @@ -1679,8 +1838,8 @@ is made `explain-pause-top-mode', `explain-pause-mode' is also enabled." explain-pause-top--buffer-table (copy-sequence explain-pause-top--command-entry-headers) ;; 3 extra slots - ;; - cmd main line - ;; - cmd extra lines + ;; - cmd lines + ;; - slow lines ;; - profile lines (+ (length explain-pause-top--command-entry-headers) 3)) @@ -1690,70 +1849,85 @@ is made `explain-pause-top-mode', `explain-pause-mode' is also enabled." ;; TODO hardcoded col index (explain-pause-top--apply-sort 1 t) - (let ((this-buffer (current-buffer))) - (when explain-pause-top--buffer-window-size-changed - (remove-hook 'window-size-change-functions - explain-pause-top--buffer-window-size-changed)) + (when explain-pause-top--buffer-window-size-changed + (remove-hook 'window-size-change-functions + explain-pause-top--buffer-window-size-changed)) - (setq-local explain-pause-top--buffer-window-size-changed + (setq-local explain-pause-top--buffer-window-size-changed + (let ((this-buffer (current-buffer))) (lambda (_) ;; ignore frame, and recalculate the width across all frames ;; every time. we always need the biggest. (explain-pause-top--buffer-update-width-from-windows this-buffer)))) - (let ((this-commands explain-pause-top--buffer-statistics)) - (when explain-pause-top--buffer-command-pipe - (remove-hook 'explain-pause-measured-command-hook - explain-pause-top--buffer-command-pipe)) - - (setq-local - explain-pause-top--buffer-command-pipe + (when explain-pause-top--buffer-command-pipe + (remove-hook 'explain-pause-measured-command-hook + explain-pause-top--buffer-command-pipe)) + + (setq-local + explain-pause-top--buffer-command-pipe + (let ((this-commands explain-pause-top--buffer-statistics) + ;; store these in the closure so we don't reallocate every command + (command-set nil) + (entry nil) + (new-count nil) + (new-ms nil)) (lambda (record) + ;; this lambda is called ON EVERY SINGLE COMMAND is it is important + ;; to not use a let and allocate the minimum required. ;; ignore native frames for now - TODO (unless (explain-pause-command-record-native record) - (let* ((ms (explain-pause-command-record-executing-time record)) - ;;TODO command-set list. - (command-set (list (explain-pause-command-record-command record))) - (entry (gethash command-set this-commands nil)) - (this-slow-count - (if (> ms explain-pause-slow-too-long-ms) 1 0)) - (profiles (aref (explain-pause-profile--get record) 1))) - (if entry - ;; update. - (let* - ((old-count - (explain-pause-top--value-or-n/a-default - (explain-pause-top--command-entry-count entry))) - (old-ms - (explain-pause-top--value-or-n/a-default - (explain-pause-top--command-entry-total-ms entry))) - (slow-count - (explain-pause-top--command-entry-slow-count entry)) - (new-count (1+ old-count)) - (new-slow-count (+ slow-count this-slow-count)) - (new-ms (+ ms old-ms)) - (new-avg (/ (float new-ms) (float new-count)))) - (setf (explain-pause-top--command-entry-count entry) new-count) - (setf (explain-pause-top--command-entry-slow-count entry) new-slow-count) - (setf (explain-pause-top--command-entry-total-ms entry) new-ms) - (setf (explain-pause-top--command-entry-avg-ms entry) new-avg) - (setf (explain-pause-top--command-entry-profiles entry) profiles) - (setf (explain-pause-top--command-entry-dirty entry) t)) - ;; new. - (setq entry (make-explain-pause-top--command-entry - :command-set command-set - :count 1 - :avg-ms ms - :total-ms ms - :slow-count this-slow-count - :dirty 'new - :profiles profiles))) - - (puthash command-set entry this-commands))))) - - (add-hook 'explain-pause-measured-command-hook - explain-pause-top--buffer-command-pipe t)) + ;; TODO command-list + (setq command-set (list (explain-pause-command-record-command record))) + (setq entry (gethash command-set this-commands nil)) + (cond + (entry + ;; update. + (setq new-count (1+ (explain-pause-top--value-or-n/a-default + (explain-pause-top--command-entry-count entry)))) + + (setq new-ms (+ (explain-pause-command-record-executing-time record) + (explain-pause-top--value-or-n/a-default + (explain-pause-top--command-entry-total-ms entry)))) + + (setf (explain-pause-top--command-entry-count entry) new-count) + (setf (explain-pause-top--command-entry-total-ms entry) new-ms) + (setf (explain-pause-top--command-entry-avg-ms entry) + (/ (float new-ms) (float new-count))) + + (setf (explain-pause-top--command-entry-slow-count entry) + (+ (explain-pause-top--command-entry-slow-count entry) + (if (explain-pause-command-record-too-slow record) 1 0))) + + (setf (explain-pause-top--command-entry-profiles entry) + (explain-pause-profile--statistic-profiles record)) + + (setf (explain-pause-top--command-entry-slow-index entry) + (explain-pause-profile--statistic-slow-index record)) + + (setf (explain-pause-top--command-entry-dirty entry) t)) + (t + ;; new. + (puthash command-set + (make-explain-pause-top--command-entry + :command-set command-set + :count 1 + :avg-ms + (explain-pause-command-record-executing-time record) + :total-ms + (explain-pause-command-record-executing-time record) + :slow-count + (if (explain-pause-command-record-too-slow record) 1 0) + :dirty 'new + :slow-index + (explain-pause-profile--statistic-slow-index record) + :profiles + (explain-pause-profile--statistic-profiles record)) + this-commands))))))) + + (add-hook 'explain-pause-measured-command-hook + explain-pause-top--buffer-command-pipe t) (add-hook 'window-size-change-functions explain-pause-top--buffer-window-size-changed) @@ -1773,22 +1947,21 @@ is made `explain-pause-top-mode', `explain-pause-mode' is also enabled." (unless explain-pause-mode (explain-pause-mode)) - ;; create entries for all slow profiles + ;; create entries for all slow commands (maphash (lambda (command statistic) - (let ((command-set (list command)) ;; TODO command-set list - (profiles (aref statistic 1))) - - (when profiles + ;; TODO abstraction for statistic? + (when (> (aref statistic 4) 0) + (let ((command-set (list command))) ;; TODO command-set list (puthash command-set (make-explain-pause-top--command-entry :command-set command-set :count explain-pause-top--n/a-value - ;; TODO we should improve this once we get slow ms list - :slow-count (length profiles) + :slow-count (aref statistic 4) :avg-ms explain-pause-top--n/a-value :total-ms explain-pause-top--n/a-value :dirty 'new - :profiles profiles) + :slow-index (aref statistic 5) + :profiles (aref statistic 3)) explain-pause-top--buffer-statistics)))) explain-pause-profile--profile-statistics) @@ -1829,11 +2002,6 @@ is made `explain-pause-top-mode', `explain-pause-mode' is also enabled." (with-current-buffer buffer ;; clear the timer as we just ran (setq-local explain-pause-top--buffer-refresh-timer nil) - (when explain-pause-log--send-process - (process-send-string - explain-pause-log--send-process - (format "enter w current buffer %s\n" - (current-time)))) (explain-pause-top--buffer-refresh) (explain-pause-top--buffer-reschedule-timer))) @@ -1843,34 +2011,21 @@ is made `explain-pause-top-mode', `explain-pause-mode' is also enabled." (with-current-buffer buffer (explain-pause-top--buffer-refresh))) +(defsubst explain-pause-top--buffer-upsert-entry (_ item) + "Upsert an item from the map of entries in a buffer." + ;; deliberately call aref twice instead of letting a new scope. + ;; this is in a very tight loop. + (cond + ((eq (explain-pause-top--command-entry-dirty item) 'new) + (explain-pause-top--table-insert explain-pause-top--buffer-table item)) + ((explain-pause-top--command-entry-dirty item) + (explain-pause-top--table-update explain-pause-top--buffer-table item)))) + (defun explain-pause-top--buffer-refresh () "Refresh the current buffer - redraw the data at the current target-width" ;; first, insert all the items - ;; TODO: is this slow? no documentation on cost of iteration - (when explain-pause-log--send-process - (process-send-string - explain-pause-log--send-process - (format "refresh enter %s\n" - (current-time)))) - - (let ((addcount 0) - (updatecount 0)) - (maphash - (lambda (_ item) - (let ((dirty (explain-pause-top--command-entry-dirty item))) - (cond - ((eq dirty 'new) - (explain-pause-top--table-insert explain-pause-top--buffer-table item) - (setq addcount (1+ addcount))) - (dirty - (explain-pause-top--table-update explain-pause-top--buffer-table item) - (setq updatecount (1+ updatecount)) - )))) - explain-pause-top--buffer-statistics) - (when explain-pause-log--send-process - (process-send-string - explain-pause-log--send-process - (format "finish map %s %d %d\n" (current-time) addcount updatecount)))) + (maphash #'explain-pause-top--buffer-upsert-entry + explain-pause-top--buffer-statistics) ;; It's possible a refresh timer ran before/after we calculated size, if so, ;; don't try to draw yet. @@ -1878,27 +2033,13 @@ is made `explain-pause-top-mode', `explain-pause-mode' is also enabled." (let ((inhibit-read-only t) (point-in-entry (explain-pause-top--display-entry-from-point))) (save-match-data - (when explain-pause-log--send-process - (process-send-string - explain-pause-log--send-process - (format "before refresh %s\n" - (current-time)))) - (explain-pause-top--table-refresh explain-pause-top--buffer-table) ;; move the cursor back (when point-in-entry (goto-char (+ (explain-pause-top--table-display-entry-begin-mark (car point-in-entry)) - (cdr point-in-entry)))) - - (when explain-pause-log--send-process - (process-send-string - explain-pause-log--send-process - (format "after refresh %s %s\n" - (current-time) - (memory-use-counts) - ))))))) + (cdr point-in-entry)))))))) (defun explain-pause-top--buffer-window-config-changed () "Buffer-local hook run when window config changed for a window showing @@ -2150,10 +2291,12 @@ If you change this value, the filename you specify must be writable by Emacs." (when explain-pause-log--send-process (process-send-string explain-pause-log--send-process - (format "('profile-start %s %s %d)\n" + (format "('profile-start %s %s %s)\n" (current-time) (explain-pause-command-record-command record) - (explain-pause-profile--count record))))) + ;; TODO - abstraction layer? + (gethash (explain-pause-command-record-command record) + explain-pause-profile--profile-statistics))))) (defsubst explain-pause-log--send-profile-end (record) "Send the fact that we are ending profiling to the send pipe" @@ -2204,13 +2347,12 @@ and when execution contexts switch, (e.g. timer <-> command loop).") ;; most related actions here are inline subsitutions for performance reasons (defsubst explain-pause--command-record-and-store (record) "Calculate the time since entry-snap of RECORD and add it to executing-time." - (let ((so-far (explain-pause-command-record-executing-time record))) - (setf (explain-pause-command-record-executing-time record) - (+ so-far - (explain-pause--as-ms-exact - (time-subtract - (current-time) - (explain-pause-command-record-entry-snap record))))))) + (setf (explain-pause-command-record-executing-time record) + (+ (explain-pause-command-record-executing-time record) + (explain-pause--as-ms-exact + (time-subtract + (current-time) + (explain-pause-command-record-entry-snap record)))))) (defsubst explain-pause--command-record-start-profiling (record) "Start profiling and record that in RECORD." @@ -2226,7 +2368,8 @@ and when execution contexts switch, (e.g. timer <-> command loop).") ;; make-profile: (profiler-cpu-stop) ;; only bother saving the profile if it was slow: - (when (explain-pause--command-record-slow-p record) + (when (> (explain-pause-command-record-executing-time record) + explain-pause-slow-too-long-ms) (setf (explain-pause-command-record-profile record) (profiler-make-profile :type 'cpu @@ -2236,11 +2379,12 @@ and when execution contexts switch, (e.g. timer <-> command loop).") (defsubst explain-pause--command-record-profile-p (record) "Should the command-record RECORD be profiled, taking into account existing -profiling conditions and nativeness? Calls `explain-pause-profile--command-p' as -part of this determination." - (and (not (explain-pause-command-record-native record)) +profiling conditions and nativeness? Calls +`explain-pause-profile--statistic-profile-p' as part of this determination." + (and explain-pause-profile-enabled + (not (explain-pause-command-record-native record)) (not (explain-pause-command-record-under-profile record)) - (explain-pause-profile--command-p record))) + (explain-pause-profile--statistic-profile-p record))) (defsubst explain-pause--command-record-from-parent (current-command parent command &optional native) @@ -2296,6 +2440,13 @@ protect. After, pause-and-store the RECORD, and verify that ,record) ,@body))))) +(defsubst explain-pause--run-measure-hook (new-frame) + "Finalize frame and send it to the measure hook" + (setf (explain-pause-command-record-too-slow new-frame) + (> (explain-pause-command-record-executing-time new-frame) + explain-pause-slow-too-long-ms)) + (run-hook-with-args 'explain-pause-measured-command-hook new-frame)) + (defmacro explain-pause--pause-call-unpause (new-record-form function-form) "Pause current record; create a new record using NEW-RECORD-FORM; `explain-pause--set-command-call' FUNCTION-FORM; run @@ -2309,7 +2460,7 @@ is bound throughout as the current record." new-frame ,function-form - (run-hook-with-args 'explain-pause-measured-command-hook new-frame) + (explain-pause--run-measure-hook new-frame) (setf (explain-pause-command-record-entry-snap current-record) (current-time)) @@ -2474,18 +2625,18 @@ a native frame." target-function) ;; hm, TODO polymorphic type.. ;; top-frame = the real frame. exit: - (explain-pause--command-record-and-store top-frame) ;; if we profiled, save it: (when (explain-pause-command-record-is-profiled top-frame) (explain-pause--command-record--save-and-stop-profiling top-frame)) (explain-pause-log--send-command-exit top-frame) - (run-hook-with-args 'explain-pause-measured-command-hook top-frame) + (explain-pause--run-measure-hook top-frame) ;; exit the parent frame (the command-frame from this function) ;; since we don't bother restarting, we don't need to pause-and-store (explain-pause-log--send-command-exit command-frame) - (run-hook-with-args 'explain-pause-measured-command-hook command-frame)) + (explain-pause--run-measure-hook command-frame)) + ;; no extra-frame, top-frame = command-frame (if (not (eq top-frame command-frame)) (explain-pause-report-measuring-bug @@ -2497,7 +2648,7 @@ a native frame." (when (explain-pause-command-record-is-profiled command-frame) (explain-pause--command-record--save-and-stop-profiling command-frame)) (explain-pause-log--send-command-exit command-frame) - (run-hook-with-args 'explain-pause-measured-command-hook command-frame)))) + (explain-pause--run-measure-hook command-frame)))) ;; restart parent (unless (eq parent explain-pause-root-command-loop) From 5fa5eeaa7209487c0c11e099526769166acea349 Mon Sep 17 00:00:00 2001 From: Lin Xu Date: Tue, 23 Jun 2020 23:16:39 -0700 Subject: [PATCH 03/13] Add tests; fix developer-alert; fix interactive-check. --- explain-pause-mode.el | 66 ++--- tests/test-command-logging.el | 8 +- tests/{test-timers.el => test-measurement.el} | 45 ++- tests/test-profile-measurement.el | 256 ++++++++++++++++++ 4 files changed, 341 insertions(+), 34 deletions(-) rename tests/{test-timers.el => test-measurement.el} (79%) create mode 100644 tests/test-profile-measurement.el diff --git a/explain-pause-mode.el b/explain-pause-mode.el index a76df92..ef0916d 100644 --- a/explain-pause-mode.el +++ b/explain-pause-mode.el @@ -41,6 +41,7 @@ (require 'profiler) (require 'subr-x) (require 'nadvice) +(require 'cl-macs) ;; customizable behavior (defgroup explain-pause nil @@ -1775,8 +1776,10 @@ not active." (if (minibufferp (current-buffer)) ;; try again (setq alert-timer - (run-with-idle-timer 0.5 nil - #'explain-pause-mode--log-alert-developer-display)) + (run-with-idle-timer + (time-add (current-idle-time) 0.5) + nil + #'explain-pause-mode--log-alert-developer-display)) ;; ok, let's draw (message "Emacs was slow: %s ms%s%s" (mapconcat #'number-to-string notifications ", ") @@ -2470,36 +2473,35 @@ is bound throughout as the current record." (defsubst explain-pause--interactive-form-needs-frame-p (form) "Calculate, as quickly as possible, whether this interactive form needs a native frame." - ;; deliberately order p's first, then check for common forms, then do a - ;; expensive per character check. - - ;; TODO read the bytecode, is this actually fastest? should we use a `cond' - ;; maybe this should be a linear scanner? hypothetically this should be - ;; O(test string length but this is clearly O(N of test characters) - (and (not (equal form "p")) - (not (equal form "P")) - ;; found in emacs source code - (not (equal form "^p")) - (not (equal form "^P")) - (not (equal form "^p\np")) - (not (equal form "*p\nP")) - (not (equal form "P\np")) - (not (equal form "p\nP")) - (not (equal form "^e")) - (not (equal form "e\np")) - (not (equal form "*")) - ;; from `callint.c' - (not (equal form "d")) - (not (equal form "U")) - (not (equal form "e")) - (not (equal form "m")) - (not (equal form "i")) - (not (equal form "r")) - ;; ok, give up and check every character: - (progn - (let ((inhibit-message t)) - (message "form - %s" form)) - t)));; (not (and (equal form "N") + ;; Walk through the characters and quit as early as possible. + (cl-loop + for char across form + with next-newline = nil + do + (cond + (next-newline + (when (eq char ?\n) + (setq next-newline nil))) + + ((or (eq char ?*) + (eq char ?^) + (eq char ?@)) + t) + + ((or (eq char ?p) + (eq char ?P) + (eq char ?d) + (eq char ?U) + (eq char ?e) + (eq char ?m) + (eq char ?i) + (eq char ?r)) + ;;TODO N + (setq next-newline t)) + + (t + (cl-return t))) + finally return nil)) ;; `call-interactively' is never called from C code. It is called from ;; `command-execute', defined in `simple.el', which IS called from C code, from diff --git a/tests/test-command-logging.el b/tests/test-command-logging.el index b26a791..d959758 100644 --- a/tests/test-command-logging.el +++ b/tests/test-command-logging.el @@ -76,7 +76,13 @@ (expect (explain-pause--command-as-string 10) :to-equal - "Unknown (please file a bug)"))) + "Unknown (please file a bug)")) + + (it "works for subrp" + (expect (explain-pause--command-as-string + (symbol-function 'read-char)) + :to-equal + "#"))) (describe "explain-pause--command-set-as-string" diff --git a/tests/test-timers.el b/tests/test-measurement.el similarity index 79% rename from tests/test-timers.el rename to tests/test-measurement.el index 185626f..5613996 100644 --- a/tests/test-timers.el +++ b/tests/test-measurement.el @@ -23,7 +23,7 @@ ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. -;;; Test timer wrapper code. +;;; Test measurement engine (describe "explain-pause--generate-timer-parent" @@ -122,3 +122,46 @@ :parent explain-pause-root-command-loop :depth 1 :native t)))))) + +(describe + "explain-pause--interactive-form-needs-frame-p" + + (it + "skips special chars" + + (expect (explain-pause--interactive-form-needs-frame-p "*p") + :to-be + nil) + + (expect (explain-pause--interactive-form-needs-frame-p "^P") + :to-be + nil) + + (expect (explain-pause--interactive-form-needs-frame-p "@e") + :to-be + nil) + + (expect (explain-pause--interactive-form-needs-frame-p "*^@P") + :to-be + nil)) + + (it + "skips until the new line" + + (expect (explain-pause--interactive-form-needs-frame-p "PnN\niM") + :to-be + nil)) + + (it + "works with no prompt" + + (expect (explain-pause--interactive-form-needs-frame-p "P\np") + :to-be + nil)) + + (it + "returns t for various interactive cases" + + (expect (explain-pause--interactive-form-needs-frame-p "Mprompt: ") + :to-be + t))) diff --git a/tests/test-profile-measurement.el b/tests/test-profile-measurement.el new file mode 100644 index 0000000..35ccbbc --- /dev/null +++ b/tests/test-profile-measurement.el @@ -0,0 +1,256 @@ +;;; -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Lin Xu + +;; Author: Lin Xu +;; Version: 0.1 +;; Created: May 18, 2020 +;; Keywords: performance speed config +;; URL: https://github.com/lastquestion/explain-pause-mode + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Test profile measurement hook functions. + +(defun assert-empty-statistics () + (expect (hash-table-count explain-pause-profile--profile-statistics) + :to-be + 0)) + +(defun circular-to-list (record statistic) + (let* ((size (explain-pause-profile--statistic-slow-length statistic)) + (start (explain-pause-profile--statistic-slow-index record))) + + (cl-loop + with list = nil + with idx = start + do + (let ((val + (aref statistic (+ explain-pause-profile--statistic-slow-count-offset + idx)))) + (when val + (setq list (cons val list))) + + (setq idx (% (1+ idx) size))) + until (eq idx start) + finally return list))) + +(describe + "explain-pause-profile--profile-statistics" + + (describe + "explain-pause-profile-clear" + + (it "clears" + (setq explain-pause-profile--profile-statistics (make-hash-table)) + (assert-empty-statistics) + (puthash 'foo [] explain-pause-profile--profile-statistics) + + (explain-pause-profile-clear) + + (assert-empty-statistics))) + + (describe + "explain-pause-profile--profile-measured-command" + (let ((foo-record (make-explain-pause-command-record + :command 'foo)) + (saved-profile nil) + (saved-threshold nil)) + + (before-all + (explain-pause-profile-clear) + (setq saved-profiles explain-pause-profile-saved-profiles) + (setq saved-threshold explain-pause-profile-slow-threshold) + (setq explain-pause-profile-saved-profiles 2) + (setq explain-pause-profile-slow-threshold 3)) + + (after-all + (setq explain-pause-profile-saved-profiles saved-profiles) + (setq explain-pause-profile-slow-threshold saved-threshold)) + + (before-each + (explain-pause-profile-clear)) + + (it + "does nothing when the record is native" + + (explain-pause-profile--profile-measured-command + (make-explain-pause-command-record + :native t)) + + (assert-empty-statistics)) + + (it + "increments count and saves slow records" + + (dotimes (i 2) + (explain-pause-profile--profile-measured-command + (make-explain-pause-command-record + :command 'foo + :executing-time (+ (* i 1000) 500) + :too-slow t))) + + (expect (explain-pause-profile--statistic-slow-count + foo-record) + :to-be + 2) + + (expect (circular-to-list + foo-record + (gethash 'foo explain-pause-profile--profile-statistics)) + :to-equal + '(1500 500))) + + (it + "throws away oldest slow record but keeps count" + + (dotimes (i 4) + (explain-pause-profile--profile-measured-command + (make-explain-pause-command-record + :command 'foo + :executing-time (+ (* i 1000) 500) + :too-slow t))) + + (expect (explain-pause-profile--statistic-slow-count + foo-record) + :to-be + 4) + + (expect (circular-to-list + foo-record + (gethash 'foo explain-pause-profile--profile-statistics)) + :to-equal + '(3500 2500))) + (it + "marks something for profiling after enough slow times" + + (dotimes (i 3) + (explain-pause-profile--profile-measured-command + (make-explain-pause-command-record + :command 'foo + :executing-time 500 + :too-slow t))) + + (expect (explain-pause-profile--statistic-profile-p + foo-record) + :to-be + t)) + + (it + "unmarks something for profiling after enough failed profiles" + + (dotimes (i 3) + (explain-pause-profile--profile-measured-command + (make-explain-pause-command-record + :command 'foo + :executing-time 500 + :too-slow t))) + + (expect (explain-pause-profile--statistic-profile-p + foo-record) + :to-be + t) + + (explain-pause-profile--profile-measured-command + (make-explain-pause-command-record + :command 'foo + :executing-time 50 + :too-slow nil + :is-profiled t)) + + (expect (explain-pause-profile--statistic-profile-p + foo-record) + :to-be + t) + + (dotimes (i 2) + (explain-pause-profile--profile-measured-command + (make-explain-pause-command-record + :command 'foo + :executing-time 50 + :too-slow nil + :is-profiled t))) + + (expect (explain-pause-profile--statistic-profile-p + foo-record) + :to-be + nil)) + + (it + "stores a profile if given" + + (explain-pause-profile--profile-measured-command + (make-explain-pause-command-record + :command 'foo + :executing-time 1000 + :too-slow t + :is-profiled t + :profile 'profile-1)) + + (let ((profiles (explain-pause-profile--statistic-profiles foo-record))) + (expect (length profiles) + :to-be + 1) + + (expect (car profiles) + :to-equal + [1000 profile-1]))) + + (it + "stores profiles in the right order" + (explain-pause-profile--profile-measured-command + (make-explain-pause-command-record + :command 'foo + :executing-time 1000 + :too-slow t + :is-profiled t + :profile 'profile-1)) + + (explain-pause-profile--profile-measured-command + (make-explain-pause-command-record + :command 'foo + :executing-time 2000 + :too-slow t + :is-profiled t + :profile 'profile-2)) + + (let ((profiles (explain-pause-profile--statistic-profiles foo-record))) + (expect (length profiles) + :to-be + 2) + + (expect profiles + :to-equal + '([2000 profile-2] + [1000 profile-1])))) + + (it + "gets rid of older profiles if out of space" + + (dotimes (i 5) + (explain-pause-profile--profile-measured-command + (make-explain-pause-command-record + :command 'foo + :executing-time (* (+ i 1) 1000) + :too-slow t + :is-profiled t + :profile (intern (format "profile-%d" i))))) + + (expect + (explain-pause-profile--statistic-profiles foo-record) + :to-equal + '([5000 profile-4] [4000 profile-3])))))) + From b667822010b46b190e9e43cb4bd7f00a3b0b7d5e Mon Sep 17 00:00:00 2001 From: Lin Xu Date: Sat, 27 Jun 2020 14:18:19 -0700 Subject: [PATCH 04/13] Add integration tests Full integration tests that run emacs in tmux so we can press keys and fully simulate a user. Use the event logging stream to connect to the driver, which is also written in elisp. Drive the driver via Make. Add test cases for most existing (fixed) bugs that are not covered at unit test layer. --- Makefile | 16 +- explain-pause-mode.el | 59 ++-- tests/cases/driver.el | 288 ++++++++++++++++++ tests/cases/process-filters-default-filter.el | 55 ++++ tests/cases/read-key-sequence-wait.el | 66 ++++ tests/cases/sit-for-inside-timers.el | 84 +++++ tests/cases/sit-for-return-value.el | 82 +++++ tests/test-command-logging.el | 20 +- 8 files changed, 634 insertions(+), 36 deletions(-) create mode 100644 tests/cases/driver.el create mode 100644 tests/cases/process-filters-default-filter.el create mode 100644 tests/cases/read-key-sequence-wait.el create mode 100644 tests/cases/sit-for-inside-timers.el create mode 100644 tests/cases/sit-for-return-value.el diff --git a/Makefile b/Makefile index a3a8131..b877fca 100644 --- a/Makefile +++ b/Makefile @@ -2,8 +2,20 @@ EMACS=emacs -.PHONY: test +# the test case that need full emacs driver +case-driver=tests/cases/driver.el +cases:=$(filter-out $(case-driver), $(wildcard tests/cases/*.el)) -test: +# all the test cases don't generate output so they need to be PHONY +.PHONY: test case-tests $(cases) + +case-tests: $(cases) + +$(cases): %.el: + emacs --batch -f toggle-debug-on-error -l $(case-driver) -l $@ -f "run-test" + +unit-tests: $(EMACS) -batch -f package-initialize -l explain-pause-mode.el -f buttercup-run-discover tests $(EMACS) -batch -l explain-pause-mode.el -l tests/manual-test-command-logging.el + +tests: unit-tests case-tests diff --git a/explain-pause-mode.el b/explain-pause-mode.el index ef0916d..c6ae8f3 100644 --- a/explain-pause-mode.el +++ b/explain-pause-mode.el @@ -2281,12 +2281,22 @@ If you change this value, the filename you specify must be writable by Emacs." (when explain-pause-log--send-process (process-send-string explain-pause-log--send-process - (format "('enter %s %s %s %s %d)\n" - (current-time) - (explain-pause-command-record-command entry) - (explain-pause-command-record-command record) - (explain-pause-command-record-command - (explain-pause-command-record-parent record)) + ;; try to be fast: use format directly, don't bother making an object + ;; and call prin1-to-string, because though that is C code, we have + ;; to allocate an list. try not to allocate memory instead. + (format "(\"enter\" \"%s\" \"%s\" \"%s\" %s %s %s %s %s %d)\n" + (explain-pause--command-as-string + (explain-pause-command-record-command record)) + (explain-pause--command-as-string + (explain-pause-command-record-command entry)) + (explain-pause--command-as-string + (explain-pause-command-record-command + (explain-pause-command-record-parent record))) + (explain-pause-command-record-native record) + (explain-pause-command-record-executing-time record) + (explain-pause-command-record-too-slow record) + (explain-pause-command-record-is-profiled record) + (explain-pause-command-record-under-profile record) (explain-pause-command-record-depth record))))) (defsubst explain-pause-log--send-profile-start (record) @@ -2294,9 +2304,9 @@ If you change this value, the filename you specify must be writable by Emacs." (when explain-pause-log--send-process (process-send-string explain-pause-log--send-process - (format "('profile-start %s %s %s)\n" - (current-time) - (explain-pause-command-record-command record) + (format "(\"profile-start\" \"%s\" %s)\n" + (explain-pause--command-as-string + (explain-pause-command-record-command record)) ;; TODO - abstraction layer? (gethash (explain-pause-command-record-command record) explain-pause-profile--profile-statistics))))) @@ -2306,9 +2316,9 @@ If you change this value, the filename you specify must be writable by Emacs." (when explain-pause-log--send-process (process-send-string explain-pause-log--send-process - (format "('profile-end %s %s %s)\n" - (current-time) - (explain-pause-command-record-command record) + (format "(\"profile-end\" \"%s\" %s)\n" + (explain-pause--command-as-string + (explain-pause-command-record-command record)) (not (eq (explain-pause-command-record-profile record) nil)))))) (defsubst explain-pause-log--send-command-exit (record) @@ -2316,18 +2326,15 @@ If you change this value, the filename you specify must be writable by Emacs." (when explain-pause-log--send-process (process-send-string explain-pause-log--send-process - (format "('exit %s %s %s %s)\n" - (current-time) - (explain-pause-command-record-command record) - (explain-pause-command-record-command - (explain-pause-command-record-parent record)) - (explain-pause-command-record-executing-time record))))) - -(defun explain-pause-log--send-measured-command (record) - (when explain-pause-log--send-process - ;; (process-send-string - ;; TODO - t)) + (format "(\"exit\" \"%s\" \"%s\" %s %s)\n" + (explain-pause--command-as-string + (explain-pause-command-record-command record)) + (explain-pause--command-as-string + (explain-pause-command-record-command + (explain-pause-command-record-parent record))) + (explain-pause-command-record-executing-time record) + (when (explain-pause-command-record-profile record) + 'profile))))) ;; advices for all the things (defun explain-pause-report-measuring-bug (current-command test-command) @@ -3118,15 +3125,11 @@ Returns the process that is connected to the socket." :family 'local :service file-socket :type 'datagram)) - (add-hook 'explain-pause-measured-command-hook - #'explain-pause-log--send-measured-command) explain-pause-log--send-process) (defun explain-pause-log-off () "Turn off logging of the event stream." (interactive) - (remove-hook 'explain-pause-measured-command-hook - #'explain-pause-log--send-measured-command) (when explain-pause-log--send-process (let ((save-process explain-pause-log--send-process)) (setq explain-pause-log--send-process nil) diff --git a/tests/cases/driver.el b/tests/cases/driver.el new file mode 100644 index 0000000..673c2f0 --- /dev/null +++ b/tests/cases/driver.el @@ -0,0 +1,288 @@ +;;; -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Lin Xu + +;; Author: Lin Xu +;; Version: 0.1 +;; Created: May 18, 2020 +;; Keywords: performance speed config +;; URL: https://github.com/lastquestion/explain-pause-mode + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Driver for integration tests that run emacs in a tmux terminal +;;; and drive full keyboard input. + +;; expects only to be run once. half the code runs in the test, half +;; in the tested emacs. + +;; test driver code: +(setq event-stream nil) + +(defun log-socket-filter (process string) + "Accept socket log input from the tested emacs and save it to +the stream buffer, and also parse it into the event-stream (which +is in reverse order.) When `exit-test-quit-emacs' is found, set +exit-command in the session." + (with-current-buffer (process-get process :socket-buffer) + (insert string)) + + ;;TODO (message string) + + (let* ((event (read string)) + (command (nth 1 event))) + + (push event event-stream) + + (when (or + (equal "exit-test-quit-emacs" command) + (equal "exit-test-debugger-invoked" command)) + (message "... emacs terminated: %s" command) + (setf (nth 5 (process-get process :session)) command)))) + +;; utility functions for walking the event stream, which is assumed +;; to be in correct order (reversed from event-stream global) +(defun find-ptr (list pred) + "Find the ptr to the first passing pred." + (find-ptr-between (cons list nil) pred)) + +(defun span (head pred-start pred-end) + "Find the span with the first passing PRED-START and first +passing PRED-END after that found PRED-START in ( start . end ), +inclusively." + (let* ((start (find-ptr head pred-start)) + (end (find-ptr start pred-end))) + + (cons start end))) + +(defun find-ptr-between (span pred) + "Find the ptr to pred between the span, inclusively." + (let ((head (car span)) + (end (cddr span))) ; one past + (if (catch 'place + (while (not (eq head end)) + (when (funcall pred (car head)) + (throw 'place t)) + (setq head (cdr head))) + nil) + head + nil))) + +(defun get-value-between (span valname) + "Get the value of valname that was set by a `value` event +in span." + (nth 2 (car (find-ptr-between span (find-by "value" valname))))) + +(defun find-by (type command) + "Create a PRED to find a event by TYPE for COMMAND." + (lambda (x) + (and (equal (nth 0 x) type) + (equal (nth 1 x) command)))) + +(defun span-func (head command) + "Find the first span that matches an enter/exit pair for +COMMAND." + (span head + (find-by "enter" command) + (find-by "exit" command))) + +(defun print-span (span) + "Print a span." + (let ((ptr (car span)) + (end (cddr span))) + (while (not (eq ptr end)) + (message "%s" (car ptr)) + (setq ptr (cdr ptr))))) + +(defun print-stream-buffer (session) + (with-current-buffer (nth 3 session) + (princ (buffer-string)))) + +;; simple test asserts. +(defmacro message-assert (test-form msg) + "print MSG, and a check mark if passed or x if failed. Set the +value `passed' to 1 if it fails. `passed' is expected to be used +as the args to `kill-emacs' by the tester. THIS DOES NOT STOP +EXECUTION by throwing (compare to `cl-assert', etc.)" + ;; TODO would be nice to have color. + `(let ((passing ,test-form)) + (message "%s %s" + ,msg + (if passing + "✓" + "✗")) + (when (not passing) + (setq passed 1)))) + +(defmacro message-assert-not (test-form msg) + `(message-assert (not ,test-form) ,msg)) + +(defun exit-measured-time (record) + "Return the measured-time from the exit record." + (nth 3 record)) + +(defun start-test (&optional filename) + "Start emacs, loading explain-pause and FILENAME, and run +`before-test' inside that emacs from that file. If FILENAME is +nil, use the file that defined the function +`before-test'. Returns the name of the session to be used by +later commands. Assumes this emacs is running at root of the +project." + + (unless filename + (setq filename (symbol-file 'before-test))) + + (message "Starting subemacs for test %s" filename) + + (let* ((name (file-name-base filename)) + (socket-filename (concat (file-name-directory filename) + name + "-socket.sock")) + (socket-buffer (format "%s-socket" name)) + (buffer (get-buffer-create socket-buffer)) + (session + (list + name + nil ;; PID + socket-filename + socket-buffer + nil ;; socket process + nil ;; dead or not + ))) + + ;; in case the previous tests crashed early + (ignore-errors (delete-file socket-filename)) + + (let* ((socket-process + (make-network-process + :name socket-buffer + :type 'datagram + :server t + :family 'local + :buffer nil + :service socket-filename + :filter 'log-socket-filter + :plist `(:socket-buffer + ,socket-buffer + :session + ,session))) + (exit-code + (call-process "tmux" nil name nil "new-session" "-d" + "-n" name + "-P" "-F" "\"#{pane_pid}\"" + "emacs" "-nw" "-Q" + "-l" + ;; TODO maybe make this calculate the paths..? + "./explain-pause-mode.el" + "-l" + "./tests/cases/driver.el" + "-l" + filename + "--eval" + (format "(setq socket-filename \"%s\")" socket-filename) + "-f" + "setup-test"))) + + (with-current-buffer name + (cond + ((eq exit-code 0) + (let ((pid-string + (buffer-substring-no-properties 2 + (- (point-max) 2)))) + ;; ok + (message "Started successfully... PID: %d" (string-to-number pid-string)) + (setf (nth 1 session) (string-to-number pid-string)) + (setf (nth 4 session) socket-process) + ;; run setup + (eval-expr session "(before-test)") + session)) + (t + ;; no good + (message "Failed to start:\n%s" (buffer-string)) + (delete-process socket-process) + (ignore-errors (delete-file socket-filename)) + (kill-emacs 1))))))) + +(defun wait-until-dead (session) + "Wait until the session is dead." + (while (not (nth 5 session)) + (accept-process-output (nth 4 session))) + ;; child died + (message "... test finished") + (delete-process (nth 4 session)) + (ignore-errors (delete-file (nth 2 session))) + (if (equal (nth 5 session) "exit-test-debugger-invoked") + (progn + (message "test failed in debugger ✗") + (kill-emacs 1)) + (finish-test session))) + +(defun session-socket-buffer (session) + "Get the name of the socket buffer in SESSION." + (nth 3 session)) + +(defun send-key (session &rest KEYS) + "Send KEYS to tmux session created by `start-test'" + (apply 'call-process "tmux" nil nil nil "send-keys" "-t" (car session) KEYS)) + +(defun m-x-run (session command) + "M-x run a command and press enter." + (send-key session "Escape" (concat "x" command) "Enter")) + +(defun eval-expr (session expr) + "M-: eval-expression expr and press enter." + (send-key session "Escape" (concat ":" expr) "Enter")) + +(defun call-after-test (session) + "Call after-test inside the emacs in SESSION by sending SIGUSR1, which +it is assumed `test-setup' has trapped." + (signal-process (nth 1 session) 'sigusr1)) + +;; inside tested code functions +(defun send-value (name val) + "Send the name/value pair to the event log. Run only inside tested code." + (process-send-string + explain-pause-log--send-process + (format "(\"value\" \"%s\" %s)\n" + name + (prin1-to-string val)))) + +(defun exit-test-quit-emacs () + (interactive) + "Call after-test, and then close and quit emacs. Run by SIGUSR1." + ;; assumed defined in test file + (after-test) + (explain-pause-log-off) + (kill-emacs)) + +(defun exit-test-debugger-invoked () + (interactive) + (explain-pause-log-off) + (kill-emacs)) + +(defun setup-test () + "Trap SIGUSR1 so we can call `after-test' inside this +emacs. Start explain-pause and connect to the logging socket. This must be +called as the last thing in `before-test'. If the debugger starts, log +into the event stream and then quit." + (add-hook 'debugger-mode-hook + (lambda () + (call-interactively 'exit-test-debugger-invoked))) + (toggle-debug-on-error) + + (define-key special-event-map [sigusr1] 'exit-test-quit-emacs) + (explain-pause-log-to-socket socket-filename) + (explain-pause-mode)) diff --git a/tests/cases/process-filters-default-filter.el b/tests/cases/process-filters-default-filter.el new file mode 100644 index 0000000..47a9940 --- /dev/null +++ b/tests/cases/process-filters-default-filter.el @@ -0,0 +1,55 @@ +;;; -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Lin Xu + +;; Author: Lin Xu +;; Version: 0.1 +;; Created: May 18, 2020 +;; Keywords: performance speed config +;; URL: https://github.com/lastquestion/explain-pause-mode + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; test case for #44, nil dereference because nil is the default +;;; process handler + +(defun before-test () + (setq proc (make-process + :name "test" + :buffer "test" + :command '("bash"))) + + (set-process-filter proc nil)) + +(defun cause-input () + (process-send-string proc "ls -al\n")) + +(defun after-test () + (delete-process proc)) + +;; driver code +(defun run-test () + (let ((session (start-test))) + ;; TODO do we need this? + (sleep-for 0.5) + (eval-expr session "(cause-input)") + (sleep-for 0.25) + (call-after-test session) + (wait-until-dead session))) + +(defun finish-test (session) + ;; if we didn't die in debugger, we succeeded + (kill-emacs 0)) diff --git a/tests/cases/read-key-sequence-wait.el b/tests/cases/read-key-sequence-wait.el new file mode 100644 index 0000000..1a873c8 --- /dev/null +++ b/tests/cases/read-key-sequence-wait.el @@ -0,0 +1,66 @@ +;;; -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Lin Xu + +;; Author: Lin Xu +;; Version: 0.1 +;; Created: May 18, 2020 +;; Keywords: performance speed config +;; URL: https://github.com/lastquestion/explain-pause-mode + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; test case for #14 +;; read for key sequence and it's family should not be counted +;; TODO do all the other cases in #14 +;; under test emacs code +(defun before-test () + t) + +(defun after-test () + t) + +(defun test-read-key-sequence () + (interactive) + (let ((result (read-key-sequence nil))) + (send-value "key" result))) + +;; driver code +(defun run-test () + (let ((session (start-test))) + ;; TODO do we need this? + (sleep-for 0.5) + (m-x-run session "test-read-key-sequence") + (sleep-for 1) + (send-key session "p") + (call-after-test session) + (wait-until-dead session))) + +(defun finish-test (session) + (let* ((stream (reverse event-stream)) + (call + (span-func stream "test-read-key-sequence")) + (passed 0)) + + (message-assert + (< (exit-measured-time (cadr call)) 10) + "read-key-sequence time did not subtract") + + (message-assert + (equal (get-value-between call "key") "p") + "read-key-sequence did not return read key") + + (kill-emacs passed))) diff --git a/tests/cases/sit-for-inside-timers.el b/tests/cases/sit-for-inside-timers.el new file mode 100644 index 0000000..71c1591 --- /dev/null +++ b/tests/cases/sit-for-inside-timers.el @@ -0,0 +1,84 @@ +;;; -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Lin Xu + +;; Author: Lin Xu +;; Version: 0.1 +;; Created: May 18, 2020 +;; Keywords: performance speed config +;; URL: https://github.com/lastquestion/explain-pause-mode + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; test case for #31, test sit for inside a timer. Some people do +;;; that. Evil. + +(defun before-test () + (setq minibuffer-message-timeout 1)) + +(defun timer-func () + (minibuffer-message "a long message")) + +(defun run-timer-non-interactively () + (setq sit-timer + (run-with-timer 0.25 nil 'timer-func))) + +(defun run-timer-interactively () + (interactive) + (setq sit-timer + (run-with-timer 0.25 nil 'timer-func))) + +(defun after-test () + t) + +;; driver code +(defun run-test () + (let ((session (start-test))) + ;; TODO do we need this? + (sleep-for 0.5) + (eval-expr session "(run-timer-non-interactively)") + (sleep-for 1.5) + (m-x-run session "run-timer-interactively") + (sleep-for 1.5) + (m-x-run session "run-timer-interactively") + (sleep-for 0.75) + (send-key session "p") + (call-after-test session) + (wait-until-dead session))) + +(defun finish-test (session) + (let* ((stream (reverse event-stream)) + (non-interactive-timer + (span-func stream "timer-func")) + (interactive-timer-1 + (span-func (cddr non-interactive-timer) "timer-func")) + (interactive-timer-2 + (span-func (cddr interactive-timer-1) "timer-func")) + (passed 0)) + + (message-assert + (< (exit-measured-time (cadr non-interactive-timer)) 2) + "Timer non-interactive did not subtract sit-for") + + (message-assert + (< (exit-measured-time (cadr interactive-timer-1)) 2) + "Timer interactive did not subtract sit-for") + + (message-assert + (< (exit-measured-time (cadr interactive-timer-2)) 2) + "Timer interactive interrupted with keys did not subtract sit-for") + + (kill-emacs passed))) diff --git a/tests/cases/sit-for-return-value.el b/tests/cases/sit-for-return-value.el new file mode 100644 index 0000000..7e5d98b --- /dev/null +++ b/tests/cases/sit-for-return-value.el @@ -0,0 +1,82 @@ +;;; -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Lin Xu + +;; Author: Lin Xu +;; Version: 0.1 +;; Created: May 18, 2020 +;; Keywords: performance speed config +;; URL: https://github.com/lastquestion/explain-pause-mode + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; test case for #6 and #7 +;; sit-for did not keep the return value +;; check also the duration is not counted + +;; under test emacs code +(defun before-test () + t) + +(defun after-test () + t) + +(defun test-sit-for () + (interactive) + (send-value "waited" (sit-for 2))) + +;; driver code +(defun run-test () + (let ((session (start-test))) + ;; TODO do we need this? + (sleep-for 0.5) + (m-x-run session "test-sit-for") + (sleep-for 3) + (m-x-run session "test-sit-for") + (sleep-for 0.2) + (send-key session "t") + (call-after-test session) + (wait-until-dead session))) + +(defun finish-test (session) + (let* ((stream (reverse event-stream)) + ;; the first result: + (first-call + (span-func stream "test-sit-for")) + + ;; the second result + (second-call + (span-func (cdr first-call) "test-sit-for")) + + (passed 0)) + + (message-assert + (< (exit-measured-time (cadr first-call)) 10) + "sit-for full-time did not subtract") + + (message-assert + (eq (get-value-between first-call "waited") t) + "sit for full-time did not return t") + + (message-assert + (< (exit-measured-time (cadr second-call)) 10) + "sit-for part-time did not subtract") + + (message-assert + (eq (get-value-between second-call "waited") nil) + "sit-for part time did not return nil") + + (kill-emacs passed))) diff --git a/tests/test-command-logging.el b/tests/test-command-logging.el index d959758..cf7d4ef 100644 --- a/tests/test-command-logging.el +++ b/tests/test-command-logging.el @@ -35,6 +35,8 @@ "foo")) (it "works for evil symbols" + ;; issue #15 + ;; %s is expected to remain, the printer needs to handle it (expect (explain-pause--command-as-string 'foo-%s) :to-equal @@ -50,19 +52,25 @@ (expect (explain-pause--command-as-string ;; note that we are in a lexcial binding file. ;; check manual-test-command-logging for closure. - (lambda (arglist is long))) + (lambda (arglist this-is %s-crazy))) :to-equal + " (arg-list: (arglist this-is %s-crazy))")) + + (it "prints closures with evil argument lists" + ;; issue #15 + ;; see above + (expect (explain-pause--command-as-string + ;; note that we are in a lexical binding file. + ;; check manual-test-command-logging for closure. + (lambda (arglist is long))) + :to-equal " (arg-list: (arglist is long))")) (it "prints bytecode for bytecode lambdas" (expect (explain-pause--command-as-string (byte-compile (lambda () (with-no-warnings - ;; ignore the fact we have %s in the format - ;; specifier without args. test here that - ;; %s and \n is not in the message. Relates - ;; to issue #15. - (message "astring \n %s %%s"))))) + (message "astring"))))) :to-equal " (references: (message))")) From 36c1549861344b6495b6971dade4e92af1994b5a Mon Sep 17 00:00:00 2001 From: Lin Xu Date: Sat, 27 Jun 2020 22:46:07 -0700 Subject: [PATCH 05/13] Add more tests for startup modes and make test driver more reliable. --- explain-pause-mode.el | 207 +++++++++++------- tests/cases/.emacs.d/init.el | 6 + tests/cases/driver.el | 172 ++++++++++----- tests/cases/fail-install-nice-message.el | 64 ++++++ .../install-with-minibuffer-interactive.el | 65 ++++++ tests/cases/startup-in-init.el | 71 ++++++ 6 files changed, 448 insertions(+), 137 deletions(-) create mode 100644 tests/cases/.emacs.d/init.el create mode 100644 tests/cases/fail-install-nice-message.el create mode 100644 tests/cases/install-with-minibuffer-interactive.el create mode 100644 tests/cases/startup-in-init.el diff --git a/explain-pause-mode.el b/explain-pause-mode.el index c6ae8f3..defa11e 100644 --- a/explain-pause-mode.el +++ b/explain-pause-mode.el @@ -2337,17 +2337,23 @@ If you change this value, the filename you specify must be writable by Emacs." 'profile))))) ;; advices for all the things -(defun explain-pause-report-measuring-bug (current-command test-command) +(defun explain-pause-report-measuring-bug (where current-command test-command) "Ask the user to report a bug when the frames do not match" ;; turn off everything we can (profiler-cpu-stop) (explain-pause-mode -1) - (let ((inhibit-message t)) - (message "frames do not match\ncurrent:\n%s\ntest:\n %s" - current-command - test-command)) - (debug)) ;; TODO, yes yes + (with-output-to-temp-buffer + "explain-pause-mode-report-bug" + (princ "Explain-pause-mode: please report this bug by creating a Github +issue at https://github.com/lastquestion/explain-pause-mode. Explain-pause-mode +is now _disabled_ so you can continue to hopefully use Emacs. Info follows:\n\n\n") + (princ (format "frames do not match in '%s'\ncurrent:\n%s\ntest:\n%s\n\n\n" + where + current-command + test-command)) + (princ "Backtrace:\n") + (backtrace))) (defvar explain-pause--current-command-record nil "The current command records representing what we are currently @@ -2410,19 +2416,18 @@ frame as native." :depth (1+ (explain-pause-command-record-depth parent)))) -(defsubst explain-pause--check-not-top-level () +(defmacro explain-pause--check-not-top-level (where &rest body) "Check that the `explain-pause--current-command-record' is not top level aka `explain-pause-root-command-loop' and if it is, ask the user to report an error, -returning `nil' if so." - (if (eq explain-pause--current-command-record explain-pause-root-command-loop) - (progn - (explain-pause-report-measuring-bug - explain-pause--current-command-record - explain-pause-root-command-loop) - nil) - t)) +otherwise execute BODY. This is a macro to avoid execution of WHERE unless needed." + `(if (eq explain-pause--current-command-record explain-pause-root-command-loop) + (explain-pause-report-measuring-bug + (format "not top level in %s" ,where) + explain-pause--current-command-record + explain-pause-root-command-loop) + ,@body)) -(defmacro explain-pause--set-command-call (record form &rest body) +(defmacro explain-pause--set-command-call (where record form &rest body) "Set `explain-pause--current-command-record' to RECORD and update it's entry-snap to `current-time'. Profile if requested, around FORM with unwind protect. After, pause-and-store the RECORD, and verify that @@ -2446,6 +2451,7 @@ protect. After, pause-and-store the RECORD, and verify that (explain-pause-log--send-command-exit ,record) (if (not (eq explain-pause--current-command-record ,record)) (explain-pause-report-measuring-bug + ,where explain-pause--current-command-record ,record) ,@body))))) @@ -2457,7 +2463,7 @@ protect. After, pause-and-store the RECORD, and verify that explain-pause-slow-too-long-ms)) (run-hook-with-args 'explain-pause-measured-command-hook new-frame)) -(defmacro explain-pause--pause-call-unpause (new-record-form function-form) +(defmacro explain-pause--pause-call-unpause (where new-record-form function-form) "Pause current record; create a new record using NEW-RECORD-FORM; `explain-pause--set-command-call' FUNCTION-FORM; run `explain-pause-measured-command-hook'; unpause current record. `current-record' @@ -2467,6 +2473,7 @@ is bound throughout as the current record." (let ((new-frame ,new-record-form)) (explain-pause--set-command-call + ,where new-frame ,function-form @@ -2630,6 +2637,7 @@ a native frame." command-frame))) ;; uhoh (explain-pause-report-measuring-bug + "call-interactively extra-frame" top-frame target-function) ;; hm, TODO polymorphic type.. @@ -2649,6 +2657,7 @@ a native frame." ;; no extra-frame, top-frame = command-frame (if (not (eq top-frame command-frame)) (explain-pause-report-measuring-bug + "call interactively" top-frame command-frame) ;; exit command-frame: @@ -2695,14 +2704,16 @@ much time the native code in `call-interatively' took." (defun explain-pause--wrap-native (original-func &rest args) "Advise a native function. Insert a new native command record, so we can track any calls back into elisp." - (when (explain-pause--check-not-top-level) - (explain-pause--pause-call-unpause - (explain-pause--command-record-from-parent - current-record - current-record - original-func - t) - (apply original-func args)))) + (explain-pause--check-not-top-level + (format "wrap-native for %s" original-func) + (explain-pause--pause-call-unpause + (format "wrap-native for %s" original-func) + (explain-pause--command-record-from-parent + current-record + current-record + original-func + t) + (apply original-func args)))) (defun explain-pause--wrap-completing-read-family (original-func &rest args) ;; read-command -> Fcompleting_read @@ -2721,26 +2732,30 @@ any calls back into elisp." ;; `completing-read-function'. ;; don't bother creating a native frame for it. Instead create a regular ;; frame for the `completing-read-function' _itself_ - (when (explain-pause--check-not-top-level) - (explain-pause--pause-call-unpause - (explain-pause--command-record-from-parent - current-record - current-record - completing-read-function) - (apply original-func args)))) + (explain-pause--check-not-top-level + (format "completing-read for %s" original-func) + (explain-pause--pause-call-unpause + (format "completing-read for %s" original-func) + (explain-pause--command-record-from-parent + current-record + current-record + completing-read-function) + (apply original-func args)))) (defun explain-pause--wrap-read-buffer (original-func &rest args) "Wrap read-buffer in particular, as it calls one of two completion functions depending on the arguments." - (when (explain-pause--check-not-top-level) - (explain-pause--pause-call-unpause - (explain-pause--command-record-from-parent - current-record - current-record - ;; read-buffer picks based on whether `read-buffer-function' is nil - (or read-buffer-function - completing-read-function)) - (apply original-func args)))) + (explain-pause--check-not-top-level + "read-buffer" + (explain-pause--pause-call-unpause + "read-buffer" + (explain-pause--command-record-from-parent + current-record + current-record + ;; read-buffer picks based on whether `read-buffer-function' is nil + (or read-buffer-function + completing-read-function)) + (apply original-func args)))) ;; timer or process io hooks code (defun explain-pause--wrap-callback @@ -2756,6 +2771,7 @@ callback with a new command record whose parent is PARENT-COMMAND-RECORD." ;; been profiled, but we are now executing in a new context - all wrappers ;; are either timers, process, etc. (explain-pause--pause-call-unpause + (format "wrap callback for %s" original-cb) (explain-pause--command-record-from-parent current-record parent-command-record @@ -2983,54 +2999,68 @@ callback." read-command read-function read-variable - completing-read))) + completing-read)) + (install-attempt 0)) + + (defun explain-pause-mode--install-hooks () + "Actually install hooks for `explain-pause-mode'." + (advice-add 'call-interactively :around + #'explain-pause--wrap-call-interactively) + (advice-add 'funcall-interactively :before + #'explain-pause--before-funcall-interactively) + + ;; OK, we're prepared to advise native functions and timers: + (dolist (native-func native) + (advice-add native-func :around + #'explain-pause--wrap-native)) + + (dolist (completing-read-func completing-read-family) + (advice-add completing-read-func :around + #'explain-pause--wrap-completing-read-family)) + + (advice-add 'read-buffer :around #'explain-pause--wrap-read-buffer) + + (dolist (process-func make-process-family) + (advice-add process-func :around + #'explain-pause--wrap-make-process)) + + (dolist (callback-func callback-family) + (advice-add (car callback-func) :filter-args (cdr callback-func))) + + (advice-add 'file-notify-add-watch :filter-args + #'explain-pause--wrap-file-notify-add-watch) + + (setq explain-pause--current-command-record + explain-pause-root-command-loop) + + (message "Explain-pause-mode enabled.")) (defun explain-pause-mode--enable-hooks () - "Enable hooks for `explain-pause-mode' if it is being run at the top of the + "Install hooks for `explain-pause-mode' if it is being run at the top of the emacs loop, e.g. not inside `call-interactively' or `sit-for' or any interleaved -timers, etc." - (if nil - (message "Unable to install `explain-pause-mode', please report a bug to \ +timers, etc. Otherwise, wait for next invocation." + (if (> install-attempt 5) + (progn + (remove-hook 'post-command-hook #'explain-pause-mode--enable-hooks) + (message "Unable to install `explain-pause-mode', please report a bug to \ github.com/lastquestion/explain-pause-mode") + (setq explain-pause-mode nil)) (let ((top-of-loop t)) (mapbacktrace (lambda (_evaled func _args _flags) (unless (eq func 'explain-pause-mode--enable-hooks) (setq top-of-loop nil))) #'explain-pause-mode--enable-hooks) - (when top-of-loop - (remove-hook 'post-command-hook #'explain-pause-mode--enable-hooks) + (if (not top-of-loop) + (unless (active-minibuffer-window) + ;; well, it's definitely not going to work if the user is got + ;; a minibuffer open. wait until the minibuffer goes away. + (setq install-attempt (1+ install-attempt))) ;; ok, we're safe: - (advice-add 'call-interactively :around - #'explain-pause--wrap-call-interactively) - (advice-add 'funcall-interactively :before - #'explain-pause--before-funcall-interactively) - - ;; OK, we're prepared to advise native functions and timers: - (dolist (native-func native) - (advice-add native-func :around - #'explain-pause--wrap-native)) - - (dolist (completing-read-func completing-read-family) - (advice-add completing-read-func :around - #'explain-pause--wrap-completing-read-family)) - - (advice-add 'read-buffer :around #'explain-pause--wrap-read-buffer) - - (dolist (process-func make-process-family) - (advice-add process-func :around - #'explain-pause--wrap-make-process)) - - (dolist (callback-func callback-family) - (advice-add (car callback-func) :filter-args (cdr callback-func))) - - (advice-add 'file-notify-add-watch :filter-args - #'explain-pause--wrap-file-notify-add-watch) - - (setq explain-pause--current-command-record - explain-pause-root-command-loop))))) + (remove-hook 'post-command-hook #'explain-pause-mode--enable-hooks) + (explain-pause-mode--install-hooks))))) (defun explain-pause-mode--disable-hooks () - "Disable hooks installed by `explain-pause-mode--enable-hooks'." + "Disable hooks installed by `explain-pause-mode--install-hooks'." (advice-remove 'file-notify-add-watch #'explain-pause--wrap-file-notify-add-watch) @@ -3083,9 +3113,26 @@ must install itself after some time while Emacs is not doing anything." (cond (explain-pause-mode - ;; since we might be called inside a interactive function, we need to run - ;; this outside any command: - (add-hook 'post-command-hook #'explain-pause-mode--enable-hooks)) + (let ((is-in-init-code nil)) + ;; we need to know if we are being loaded in init.el. if so, + ;; we cannot install hooks right away, because read-event is used in + ;; `terminal-init-xterm' for some reason... there are comments in + ;; emacs code implying this could be fixed but, it's not. + ;; check for `top-level': + (mapbacktrace (lambda (_evaled func _args _flags) + (when (eq func top-level) + (setq is-in-init-code t)))) + + (if is-in-init-code + ;; use `emacs-startup-hook' as the earliest point we could hook. this + ;; runs after `command-line' which calls + ;; `tty-run-terminal-initialization' which is what calls the xterm + ;; init. + (add-hook 'emacs-startup-hook #'explain-pause-mode--enable-hooks) + ;; no, then we better run after the next command, which we hope + ;; is top level. + (setq install-attempt 0) + (add-hook 'post-command-hook #'explain-pause-mode--enable-hooks)))) (t (explain-pause-mode--disable-hooks)))) diff --git a/tests/cases/.emacs.d/init.el b/tests/cases/.emacs.d/init.el new file mode 100644 index 0000000..cb0670b --- /dev/null +++ b/tests/cases/.emacs.d/init.el @@ -0,0 +1,6 @@ +(setq auto-save-list-file-prefix nil) +(load "explain-pause-mode.el") +(load "./tests/cases/driver.el") +(setup-test) +(explain-pause-mode) + diff --git a/tests/cases/driver.el b/tests/cases/driver.el index 673c2f0..2809c45 100644 --- a/tests/cases/driver.el +++ b/tests/cases/driver.el @@ -32,26 +32,33 @@ ;; test driver code: (setq event-stream nil) +(setq stream-logs (getenv "STREAMLOGS")) +(setq wait-keys (getenv "WAITKEYS")) + (defun log-socket-filter (process string) "Accept socket log input from the tested emacs and save it to the stream buffer, and also parse it into the event-stream (which is in reverse order.) When `exit-test-quit-emacs' is found, set exit-command in the session." - (with-current-buffer (process-get process :socket-buffer) - (insert string)) + ;; unless we already quit... + (unless (nth 5 (process-get process :session)) + (with-current-buffer (process-get process :socket-buffer) + (insert string)) - ;;TODO (message string) + (when stream-logs + (princ string)) - (let* ((event (read string)) - (command (nth 1 event))) + (let* ((event (read string)) + (command (nth 1 event))) - (push event event-stream) + (push event event-stream) - (when (or - (equal "exit-test-quit-emacs" command) - (equal "exit-test-debugger-invoked" command)) - (message "... emacs terminated: %s" command) - (setf (nth 5 (process-get process :session)) command)))) + (when (or + (equal "exit-test-quit-emacs" command) + (equal "exit-test-debugger-invoked" command) + (equal "exit-test-unclean" command)) + (message "... emacs terminated: %s" command) + (setf (nth 5 (process-get process :session)) command))))) ;; utility functions for walking the event stream, which is assumed ;; to be in correct order (reversed from event-stream global) @@ -117,9 +124,11 @@ COMMAND." value `passed' to 1 if it fails. `passed' is expected to be used as the args to `kill-emacs' by the tester. THIS DOES NOT STOP EXECUTION by throwing (compare to `cl-assert', etc.)" - ;; TODO would be nice to have color. `(let ((passing ,test-form)) - (message "%s %s" + (message "\e[%sm%s %s\e[0m" + (if passing + 32 + 31) ,msg (if passing "✓" @@ -134,18 +143,31 @@ EXECUTION by throwing (compare to `cl-assert', etc.)" "Return the measured-time from the exit record." (nth 3 record)) -(defun start-test (&optional filename) - "Start emacs, loading explain-pause and FILENAME, and run -`before-test' inside that emacs from that file. If FILENAME is -nil, use the file that defined the function -`before-test'. Returns the name of the session to be used by -later commands. Assumes this emacs is running at root of the -project." +(defun start-test (&optional filename emacs-args boot-function) + "Start emacs to test. + +Unless filename is given, use the file that defines `before-test'. +Unless emacs-args is given, defaults to loading explain-pause via +`-l`. +Unless boot-function is given, calls `setup-test-boot' inside +that emacs via `-f`. +Unless boot-function is given, after startup finishes, +`eval-expr' runs `before-test'. + +Returns the session to be used by later commands. Assumes this +emacs is running at root of the project." (unless filename (setq filename (symbol-file 'before-test))) - (message "Starting subemacs for test %s" filename) + (unless emacs-args + (setq emacs-args '("-nw" "-Q" ;; no window, no init + "-l" + ;; TODO maybe make this calculate the paths..? + "./explain-pause-mode.el" + "-l" + "./tests/cases/driver.el" + ))) (let* ((name (file-name-base filename)) (socket-filename (concat (file-name-directory filename) @@ -161,7 +183,13 @@ project." socket-buffer nil ;; socket process nil ;; dead or not - ))) + )) + (boot-args (or boot-function + '("-f" "setup-test-boot")))) + + (setenv "SOCKET" socket-filename) + + (message "Starting subemacs for test %s" filename) ;; in case the previous tests crashed early (ignore-errors (delete-file socket-filename)) @@ -179,22 +207,17 @@ project." ,socket-buffer :session ,session))) - (exit-code - (call-process "tmux" nil name nil "new-session" "-d" - "-n" name - "-P" "-F" "\"#{pane_pid}\"" - "emacs" "-nw" "-Q" - "-l" - ;; TODO maybe make this calculate the paths..? - "./explain-pause-mode.el" - "-l" - "./tests/cases/driver.el" - "-l" - filename - "--eval" - (format "(setq socket-filename \"%s\")" socket-filename) - "-f" - "setup-test"))) + (args `("tmux" nil ,name nil "new-session" "-d" + "-n" ,name ;; name the session + "-P" "-F" "\"#{pane_pid}\"" ;; get us the pid for later + "emacs" + ,@emacs-args + "-l" + ,filename + ,@boot-args)) + (exit-code nil)) + + (setq exit-code (apply 'call-process args)) (with-current-buffer name (cond @@ -207,7 +230,8 @@ project." (setf (nth 1 session) (string-to-number pid-string)) (setf (nth 4 session) socket-process) ;; run setup - (eval-expr session "(before-test)") + (unless boot-function + (eval-expr session "(before-test)")) session)) (t ;; no good @@ -218,17 +242,31 @@ project." (defun wait-until-dead (session) "Wait until the session is dead." - (while (not (nth 5 session)) - (accept-process-output (nth 4 session))) - ;; child died - (message "... test finished") - (delete-process (nth 4 session)) - (ignore-errors (delete-file (nth 2 session))) - (if (equal (nth 5 session) "exit-test-debugger-invoked") - (progn - (message "test failed in debugger ✗") - (kill-emacs 1)) - (finish-test session))) + (let ((proc (nth 4 session))) + (while (not (nth 5 session)) + (accept-process-output proc)) + ;; child died + (message "... test finished") + ;; sometimes there is left over input. + ;; this only work on *nix + (let ((living t)) + (while living + (if (eq + (call-process "ps" nil nil nil "-p" + (number-to-string (nth 1 session))) + 1) + ;; dead + (setq living nil) + ;; alive + (sleep-for 0.1)))) + + (delete-process proc) + (ignore-errors (delete-file (nth 2 session))) + (if (equal (nth 5 session) "exit-test-debugger-invoked") + (progn + (message "\e[31mtest failed in debugger ✗\e[0m") + (kill-emacs 1)) + (finish-test session)))) (defun session-socket-buffer (session) "Get the name of the socket buffer in SESSION." @@ -236,6 +274,9 @@ project." (defun send-key (session &rest KEYS) "Send KEYS to tmux session created by `start-test'" + (if wait-keys + (read-from-minibuffer (format "send %s..." KEYS)) + (send-string-to-terminal ".")) (apply 'call-process "tmux" nil nil nil "send-keys" "-t" (car session) KEYS)) (defun m-x-run (session command) @@ -249,7 +290,10 @@ project." (defun call-after-test (session) "Call after-test inside the emacs in SESSION by sending SIGUSR1, which it is assumed `test-setup' has trapped." - (signal-process (nth 1 session) 'sigusr1)) + (unless (getenv "PAUSEATTACH") + (when (getenv "VERBOSE") + (message "sending sigusr1 to %s" (nth 1 session))) + (signal-process (nth 1 session) 'sigusr1))) ;; inside tested code functions (defun send-value (name val) @@ -260,23 +304,37 @@ it is assumed `test-setup' has trapped." name (prin1-to-string val)))) +(defun send-exit-record (why) + "Send an emergency exit record (needed if explain-pause didn't install)." + (process-send-string + explain-pause-log--send-process + (format "(\"enter\" \"%s\")\n" why))) + (defun exit-test-quit-emacs () (interactive) "Call after-test, and then close and quit emacs. Run by SIGUSR1." ;; assumed defined in test file (after-test) + (send-exit-record "exit-test-unclean") (explain-pause-log-off) - (kill-emacs)) + (unless (getenv "NODIE") + (kill-emacs))) (defun exit-test-debugger-invoked () (interactive) + (send-exit-record "exit-test-unclean") (explain-pause-log-off) - (kill-emacs)) + (unless (getenv "NODIE") + (kill-emacs))) + +(defun setup-test-boot () + "Setup-test and then start the mode." + (setup-test) + (explain-pause-mode)) (defun setup-test () "Trap SIGUSR1 so we can call `after-test' inside this -emacs. Start explain-pause and connect to the logging socket. This must be -called as the last thing in `before-test'. If the debugger starts, log +emacs. Connect to the logging socket. If the debugger starts, log into the event stream and then quit." (add-hook 'debugger-mode-hook (lambda () @@ -284,5 +342,5 @@ into the event stream and then quit." (toggle-debug-on-error) (define-key special-event-map [sigusr1] 'exit-test-quit-emacs) - (explain-pause-log-to-socket socket-filename) - (explain-pause-mode)) + + (explain-pause-log-to-socket (getenv "SOCKET"))) diff --git a/tests/cases/fail-install-nice-message.el b/tests/cases/fail-install-nice-message.el new file mode 100644 index 0000000..e12c2a0 --- /dev/null +++ b/tests/cases/fail-install-nice-message.el @@ -0,0 +1,64 @@ +;;; -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Lin Xu + +;; Author: Lin Xu +;; Version: 0.1 +;; Created: May 18, 2020 +;; Keywords: performance speed config +;; URL: https://github.com/lastquestion/explain-pause-mode + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Test that when you start up interactively, and we can't get a good +;;; post-command startup, we eventually give up and print a nice +;;; message. + +(defun before-test () + t) + +(defun after-test () + ;; check messages that there is a good message + (with-current-buffer (messages-buffer) + (goto-char 0) + (send-value "message-index" + (re-search-forward "Unable to install ‘explain-pause-mode’" nil t)))) + +(defun run-test () + (setq session (start-test + nil + nil + '("-f" "setup-test"))) + + (sleep-for 0.5) + + (m-x-run session "recursive-edit") + + (m-x-run session "explain-pause-mode") + + ;; more then 5 which is the give up number + (send-key session "abcdef") + + (call-after-test session) + (wait-until-dead session)) + +(defun finish-test (session) + ;; if we get here, the mode must have installed + (let ((passed 0)) + (message-assert-not + (nth 1 (find-ptr event-stream (find-by "value" "message-index"))) + "Unable to install message was not printed") + (kill-emacs passed))) diff --git a/tests/cases/install-with-minibuffer-interactive.el b/tests/cases/install-with-minibuffer-interactive.el new file mode 100644 index 0000000..a9b7122 --- /dev/null +++ b/tests/cases/install-with-minibuffer-interactive.el @@ -0,0 +1,65 @@ +;;; -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Lin Xu + +;; Author: Lin Xu +;; Version: 0.1 +;; Created: May 18, 2020 +;; Keywords: performance speed config +;; URL: https://github.com/lastquestion/explain-pause-mode + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Test that when you start up interactively, and you do so in a way +;;; that has the minibuffer open so every post-command-hook isn't +;;; at a clean root, we wait until the minibuffer is closed, and then +;;; install + +(defun before-test () + t) + +(defun start-mode () + (interactive) + (run-with-idle-timer 0.5 nil 'explain-pause-mode) + (read-from-minibuffer "evil prompt")) + +(defun after-test () + t) + +(defun run-test () + (setq session (start-test + nil + nil + '("-f" "setup-test"))) + + (sleep-for 0.5) + + (m-x-run session "start-mode") + + ;; wait long enough for the idle timer to try + (sleep-for 0.7) + + ;; more then 5, which is the give up number + ;; enter at the end calls post-command-hook for the minibuffer + ;; which then installs + (send-key session "abcdef" "Enter") + + (call-after-test session) + (wait-until-dead session)) + +(defun finish-test (session) + ;; if we get here, the mode must have installed + (kill-emacs 0)) diff --git a/tests/cases/startup-in-init.el b/tests/cases/startup-in-init.el new file mode 100644 index 0000000..9391d27 --- /dev/null +++ b/tests/cases/startup-in-init.el @@ -0,0 +1,71 @@ +;;; -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Lin Xu + +;; Author: Lin Xu +;; Version: 0.1 +;; Created: May 18, 2020 +;; Keywords: performance speed config +;; URL: https://github.com/lastquestion/explain-pause-mode + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Test that we can boot while in a init.el. Init.el is NOT the same +;;; as running with `-l`, unfortunately. + +(defun check-buffers () + "Find any buffer with backtrace or explain-pause-mode-report-bug or +if messages buffer has error message." + (cl-loop + for buffer being the buffers + do + (let ((name (buffer-name buffer))) + (when (or (string-match-p "backtrace" name) + (string-match-p "explain-pause-mode-report-bug" name) + (string-match-p "Warnings" name)) + (send-exit-record "exit-test-debugger-invoked") + (kill-emacs 1))))) + +(defun after-test () + t) + +(defun run-test () + ;; TODO ... + (let* ((filename (symbol-file 'run-test)) + (homedir (file-name-directory filename)) + (rootdir (expand-file-name homedir "../../")) + (session nil)) + + ;; save the default directory fully expanded because we're about + ;; to reset HOME: + (setq-local default-directory + (expand-file-name default-directory)) + (setenv "HOME" homedir) + (setenv "EMACSLOADPATH" (format "%s:" default-directory)) + + (setq session (start-test + filename + '("-nw" "--no-site-lisp" "--no-splash" "--no-x-resources") + '("-f" "setup-test" "-f" "check-buffers"))) + + (sleep-for 0.5) + + (call-after-test session) + (wait-until-dead session))) + +(defun finish-test (session) + ;; if we got here we didn't die during check-buffers + (kill-emacs 0)) From 5303e4a90407f002e37c21b4c3c56dcc379cb7a2 Mon Sep 17 00:00:00 2001 From: Lin Xu Date: Sat, 27 Jun 2020 22:46:51 -0700 Subject: [PATCH 06/13] add gitignore ignoring elc --- .gitignore | 1 + 1 file changed, 1 insertion(+) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..016d3b1 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +*.elc \ No newline at end of file From 4621c93b79cbf3ab05df243dec2907d7552291a4 Mon Sep 17 00:00:00 2001 From: Lin Xu Date: Mon, 29 Jun 2020 01:01:34 -0700 Subject: [PATCH 07/13] Add more tests for #26, add buffering for DGRAM, improve test driver --- explain-pause-mode.el | 69 ++++++-- tests/cases/driver.el | 150 ++++++++++++++---- .../install-with-minibuffer-interactive.el | 9 +- tests/cases/process-filters-default-filter.el | 16 +- tests/cases/read-key-sequence-wait.el | 7 +- tests/cases/sit-for-inside-filter.el | 64 ++++++++ tests/cases/sit-for-inside-timers.el | 3 +- tests/cases/sit-for-return-value.el | 3 +- tests/cases/startup-in-init.el | 7 +- tests/cases/timer-y-n-or-p.el | 87 ++++++++++ 10 files changed, 356 insertions(+), 59 deletions(-) create mode 100644 tests/cases/sit-for-inside-filter.el create mode 100644 tests/cases/timer-y-n-or-p.el diff --git a/explain-pause-mode.el b/explain-pause-mode.el index defa11e..66594bb 100644 --- a/explain-pause-mode.el +++ b/explain-pause-mode.el @@ -2276,14 +2276,62 @@ If you change this value, the filename you specify must be writable by Emacs." (defvar explain-pause-log--send-process nil "The process used to send logs to the UNIX socket.") +(defvar explain-pause-log--dgram-buffer-size 256 + "The dgram buffer size.") + +(defvar explain-pause-log--dgram-buffer + (make-vector (+ 3 explain-pause-log--dgram-buffer-size) 0) + "The vector of temporary dgrams if the receiver is full. The firsw two items +represent the push and pop indices. Reserve one empty slot to differentiate +empty and full.") + +(defun explain-pause-log--missing-socket-disable () + ;;TODO + (debug)) + +(defsubst explain-pause-log--send-dgram (str) + "Write to the socket if it is enabled. The DGRAM code has its own special +branch in process.c which is synchronous (it doesn't block). If the buffer is +full on the other side, an error is raised." + (condition-case err + (progn + (while (not (eq (aref explain-pause-log--dgram-buffer 0) + (aref explain-pause-log--dgram-buffer 1))) + (process-send-string + explain-pause-log--send-process + (aref explain-pause-log--dgram-buffer + (+ (aref explain-pause-log--dgram-buffer 0) 2))) + (setf (aref explain-pause-log--dgram-buffer 0) + (% (1+ (aref explain-pause-log--dgram-buffer 0)) + explain-pause-log--dgram-buffer-size))) + + (process-send-string + explain-pause-log--send-process + str)) + (file-error + (cond + ;; the file didn't exist; turn off logging... + ((eq (car err) 'file-missing) + (explain-pause-log--missing-socket-disable)) + ;; to avoid doing a grep over the string, assume it's just + ;; buffer full. Try to push it onto the dgrams buffer. + ((eq (car err) 'file-error) + (let ((next (% (1+ (aref explain-pause-log--dgram-buffer 1)) + explain-pause-log--dgram-buffer-size))) + (if (eq (aref explain-pause-log--dgram-buffer 0) next) + (explain-pause-log--missing-socket-disable) + (setf (aref explain-pause-log--dgram-buffer + (+ (aref explain-pause-log--dgram-buffer 1) 2)) + str) + (setf (aref explain-pause-log--dgram-buffer 1) next)))))))) + (defsubst explain-pause-log--send-command-entry (entry record) "Send the fact that we are entering RECORD from ENTRY to the send pipe." - (when explain-pause-log--send-process - (process-send-string - explain-pause-log--send-process ;; try to be fast: use format directly, don't bother making an object ;; and call prin1-to-string, because though that is C code, we have - ;; to allocate an list. try not to allocate memory instead. + ;; to allocate an list. try not to allocate memory instead. + (when explain-pause-log--send-process + (explain-pause-log--send-dgram (format "(\"enter\" \"%s\" \"%s\" \"%s\" %s %s %s %s %s %d)\n" (explain-pause--command-as-string (explain-pause-command-record-command record)) @@ -2302,8 +2350,7 @@ If you change this value, the filename you specify must be writable by Emacs." (defsubst explain-pause-log--send-profile-start (record) "Send the fact that we are beginning profiling to the send pipe" (when explain-pause-log--send-process - (process-send-string - explain-pause-log--send-process + (explain-pause-log--send-dgram (format "(\"profile-start\" \"%s\" %s)\n" (explain-pause--command-as-string (explain-pause-command-record-command record)) @@ -2314,8 +2361,7 @@ If you change this value, the filename you specify must be writable by Emacs." (defsubst explain-pause-log--send-profile-end (record) "Send the fact that we are ending profiling to the send pipe" (when explain-pause-log--send-process - (process-send-string - explain-pause-log--send-process + (explain-pause-log--send-dgram (format "(\"profile-end\" \"%s\" %s)\n" (explain-pause--command-as-string (explain-pause-command-record-command record)) @@ -2324,8 +2370,7 @@ If you change this value, the filename you specify must be writable by Emacs." (defsubst explain-pause-log--send-command-exit (record) "Send the fact that we have finished a record to the send pipes" (when explain-pause-log--send-process - (process-send-string - explain-pause-log--send-process + (explain-pause-log--send-dgram (format "(\"exit\" \"%s\" \"%s\" %s %s)\n" (explain-pause--command-as-string (explain-pause-command-record-command record)) @@ -3033,6 +3078,10 @@ callback." (setq explain-pause--current-command-record explain-pause-root-command-loop) + (when explain-pause-log--send-process + (explain-pause-log--send-dgram + "(\"enabled\")\n")) + (message "Explain-pause-mode enabled.")) (defun explain-pause-mode--enable-hooks () diff --git a/tests/cases/driver.el b/tests/cases/driver.el index 2809c45..42e2dda 100644 --- a/tests/cases/driver.el +++ b/tests/cases/driver.el @@ -30,10 +30,13 @@ ;; in the tested emacs. ;; test driver code: +(require 'seq) + (setq event-stream nil) (setq stream-logs (getenv "STREAMLOGS")) (setq wait-keys (getenv "WAITKEYS")) +(setq verbose (getenv "VERBOSE")) (defun log-socket-filter (process string) "Accept socket log input from the tested emacs and save it to @@ -53,12 +56,16 @@ exit-command in the session." (push event event-stream) - (when (or + (cond + ((or (equal "exit-test-quit-emacs" command) (equal "exit-test-debugger-invoked" command) (equal "exit-test-unclean" command)) (message "... emacs terminated: %s" command) - (setf (nth 5 (process-get process :session)) command))))) + (setf (nth 5 (process-get process :session)) command)) + ((equal "enabled" (nth 0 event)) + (message "...mode enabled") + (setf (nth 6 (process-get process :session)) t)))))) ;; utility functions for walking the event stream, which is assumed ;; to be in correct order (reversed from event-stream global) @@ -66,14 +73,17 @@ exit-command in the session." "Find the ptr to the first passing pred." (find-ptr-between (cons list nil) pred)) +(defun span-between (span pred-start pred-end) + "Find the span inside the span with PRED-START and PRED-END." + (let* ((start (find-ptr-between span pred-start)) + (end (find-ptr-between (cons (cdr start) (cdr span)) pred-end))) + (cons start end))) + (defun span (head pred-start pred-end) "Find the span with the first passing PRED-START and first passing PRED-END after that found PRED-START in ( start . end ), inclusively." - (let* ((start (find-ptr head pred-start)) - (end (find-ptr start pred-end))) - - (cons start end))) + (span-between (cons head nil) pred-start pred-end)) (defun find-ptr-between (span pred) "Find the ptr to pred between the span, inclusively." @@ -106,6 +116,13 @@ COMMAND." (find-by "enter" command) (find-by "exit" command))) +(defun span-func-between (span command) + "Find the first span inside span that matches an enter/exit +pair for COMMAND." + (span-between span + (find-by "enter" command) + (find-by "exit" command))) + (defun print-span (span) "Print a span." (let ((ptr (car span)) @@ -183,6 +200,7 @@ emacs is running at root of the project." socket-buffer nil ;; socket process nil ;; dead or not + nil ;; started or not )) (boot-args (or boot-function '("-f" "setup-test-boot")))) @@ -240,28 +258,56 @@ emacs is running at root of the project." (ignore-errors (delete-file socket-filename)) (kill-emacs 1))))))) +(let ((spin 0) + (values ["\e[D-" + "\e[D/" + "\e[D|" + "\e[D\\"])) + + (defun spinner () + (send-string-to-terminal (aref values spin)) + (setq spin (% (1+ spin) 4)))) + +(defun wait-until-ready (session) + "Wait until the mode is enabled." + (message "Waiting until ready...") + (let ((proc (nth 4 session))) + (while (not (nth 6 session)) + (spinner) + (accept-process-output))) + (message "...ready")) + (defun wait-until-dead (session) "Wait until the session is dead." (let ((proc (nth 4 session))) + (message "Waiting until dead...") (while (not (nth 5 session)) - (accept-process-output proc)) + (spinner) + (accept-process-output)) ;; child died - (message "... test finished") + (message "... finished.\nwaiting for PID to die:") ;; sometimes there is left over input. ;; this only work on *nix - (let ((living t)) - (while living - (if (eq - (call-process "ps" nil nil nil "-p" - (number-to-string (nth 1 session))) - 1) - ;; dead - (setq living nil) - ;; alive - (sleep-for 0.1)))) - + (if (getenv "NODIE") + (read-from-minibuffer "Quit?") + (let ((living t)) + (while living + (if (eq + (call-process "ps" nil nil nil "-p" + (number-to-string (nth 1 session))) + 1) + ;; dead + (setq living nil) + ;; alive + (spinner) + (sleep-for 0.1))))) + + (message "done\n") + ;; delete the network process (delete-process proc) + ;; delete the socket files (ignore-errors (delete-file (nth 2 session))) + (if (equal (nth 5 session) "exit-test-debugger-invoked") (progn (message "\e[31mtest failed in debugger ✗\e[0m") @@ -272,42 +318,88 @@ emacs is running at root of the project." "Get the name of the socket buffer in SESSION." (nth 3 session)) +(defun convert-to-hex (keys) + (seq-reduce + (lambda (accum key) + (cond + ((eq key 'enter) + (append accum (list "0D"))) + ((eq key 'escape) + (append accum (list "1B"))) + (t + (append accum + (mapcar (lambda (char) + (format "%x" char)) + key))))) + keys '())) + +(defun convert-to-str (keys) + (mapconcat (lambda (key) + (cond + ((eq key 'enter) + "") + ((eq key 'escape) + "") + (t + key))) + keys "")) + (defun send-key (session &rest KEYS) "Send KEYS to tmux session created by `start-test'" (if wait-keys (read-from-minibuffer (format "send %s..." KEYS)) - (send-string-to-terminal ".")) - (apply 'call-process "tmux" nil nil nil "send-keys" "-t" (car session) KEYS)) + (if verbose + (message "%s %s" + (convert-to-str KEYS) + (convert-to-hex KEYS)) + (send-string-to-terminal "."))) + (let ((proc (make-process + :name "tmux" + :buffer nil + :command `("tmux" "send-keys" "-H" "-t" + ,(car session) + ,@(convert-to-hex KEYS)) + :connection 'pipe))) + (while (process-live-p proc) + (when verbose + (spinner)) + (accept-process-output)))) + +(defun m-key-string (session key command) + (send-key session 'escape key) + (let ((keys (seq-partition command 5))) + (seq-doseq (key keys) + (send-key session key))) + (send-key session 'enter)) (defun m-x-run (session command) "M-x run a command and press enter." - (send-key session "Escape" (concat "x" command) "Enter")) + (m-key-string session "x" command)) (defun eval-expr (session expr) "M-: eval-expression expr and press enter." - (send-key session "Escape" (concat ":" expr) "Enter")) + (m-key-string session ":" expr)) (defun call-after-test (session) "Call after-test inside the emacs in SESSION by sending SIGUSR1, which it is assumed `test-setup' has trapped." - (unless (getenv "PAUSEATTACH") - (when (getenv "VERBOSE") + (if (getenv "PAUSEATTACH") + (message "Pausing to allow attach...") + (when verbose (message "sending sigusr1 to %s" (nth 1 session))) (signal-process (nth 1 session) 'sigusr1))) ;; inside tested code functions (defun send-value (name val) "Send the name/value pair to the event log. Run only inside tested code." - (process-send-string - explain-pause-log--send-process + (explain-pause-log--send-dgram (format "(\"value\" \"%s\" %s)\n" name (prin1-to-string val)))) (defun send-exit-record (why) "Send an emergency exit record (needed if explain-pause didn't install)." - (process-send-string - explain-pause-log--send-process + (explain-pause-log--send-dgram (format "(\"enter\" \"%s\")\n" why))) (defun exit-test-quit-emacs () diff --git a/tests/cases/install-with-minibuffer-interactive.el b/tests/cases/install-with-minibuffer-interactive.el index a9b7122..a68de19 100644 --- a/tests/cases/install-with-minibuffer-interactive.el +++ b/tests/cases/install-with-minibuffer-interactive.el @@ -55,11 +55,14 @@ ;; more then 5, which is the give up number ;; enter at the end calls post-command-hook for the minibuffer ;; which then installs - (send-key session "abcdef" "Enter") + (send-key session "abcdef" 'enter) (call-after-test session) (wait-until-dead session)) (defun finish-test (session) - ;; if we get here, the mode must have installed - (kill-emacs 0)) + (let ((passed 0)) + (message-assert + (equal (nth 5 session) "exit-test-quit-emacs") + "mode installed correctly") + (kill-emacs passed))) diff --git a/tests/cases/process-filters-default-filter.el b/tests/cases/process-filters-default-filter.el index 47a9940..5d8bffe 100644 --- a/tests/cases/process-filters-default-filter.el +++ b/tests/cases/process-filters-default-filter.el @@ -30,12 +30,12 @@ (setq proc (make-process :name "test" :buffer "test" - :command '("bash"))) + :command '("cat"))) (set-process-filter proc nil)) (defun cause-input () - (process-send-string proc "ls -al\n")) + (process-send-string proc "HI\n")) (defun after-test () (delete-process proc)) @@ -43,13 +43,15 @@ ;; driver code (defun run-test () (let ((session (start-test))) - ;; TODO do we need this? - (sleep-for 0.5) + (wait-until-ready session) (eval-expr session "(cause-input)") - (sleep-for 0.25) + (sleep-for 1) (call-after-test session) (wait-until-dead session))) (defun finish-test (session) - ;; if we didn't die in debugger, we succeeded - (kill-emacs 0)) + (let ((passed 0)) + (message-assert + (equal (nth 5 session) "exit-test-quit-emacs") + "mode installed correctly") + (kill-emacs passed))) diff --git a/tests/cases/read-key-sequence-wait.el b/tests/cases/read-key-sequence-wait.el index 1a873c8..92a2461 100644 --- a/tests/cases/read-key-sequence-wait.el +++ b/tests/cases/read-key-sequence-wait.el @@ -41,8 +41,7 @@ ;; driver code (defun run-test () (let ((session (start-test))) - ;; TODO do we need this? - (sleep-for 0.5) + (wait-until-ready session) (m-x-run session "test-read-key-sequence") (sleep-for 1) (send-key session "p") @@ -57,10 +56,10 @@ (message-assert (< (exit-measured-time (cadr call)) 10) - "read-key-sequence time did not subtract") + "read-key-sequence time subtracted") (message-assert (equal (get-value-between call "key") "p") - "read-key-sequence did not return read key") + "read-key-sequence returned actual key") (kill-emacs passed))) diff --git a/tests/cases/sit-for-inside-filter.el b/tests/cases/sit-for-inside-filter.el new file mode 100644 index 0000000..ab5af93 --- /dev/null +++ b/tests/cases/sit-for-inside-filter.el @@ -0,0 +1,64 @@ +;;; -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Lin Xu + +;; Author: Lin Xu +;; Version: 0.1 +;; Created: May 18, 2020 +;; Keywords: performance speed config +;; URL: https://github.com/lastquestion/explain-pause-mode + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Regression test case for part of #26. +;;; Test that sit-for is accounted correctly inside a process filter. + +(defun before-test () + (setq proc (make-process + :name "test" + :buffer "test" + :command '("cat") + :filter 'filter-func))) + +(defun filter-func (process string) + (sit-for 1) + (sleep-for 0.1)) + +(defun cause-input () + (process-send-string proc "HI\n")) + +(defun after-test () + (delete-process proc)) + +;; driver code +(defun run-test () + (let ((session (start-test))) + (wait-until-ready session) + (eval-expr session "(cause-input)") + (sleep-for 1.5) + (call-after-test session) + (wait-until-dead session))) + +(defun finish-test (session) + (let* ((stream (reverse event-stream)) + (filter (span-func stream "filter-func")) + (passed 0)) + + (message-assert + (< (exit-measured-time (cadr filter)) 110) + "filter time subtracted out sit-for time") + + (kill-emacs passed))) diff --git a/tests/cases/sit-for-inside-timers.el b/tests/cases/sit-for-inside-timers.el index 71c1591..46fe80b 100644 --- a/tests/cases/sit-for-inside-timers.el +++ b/tests/cases/sit-for-inside-timers.el @@ -47,8 +47,7 @@ ;; driver code (defun run-test () (let ((session (start-test))) - ;; TODO do we need this? - (sleep-for 0.5) + (wait-until-ready session) (eval-expr session "(run-timer-non-interactively)") (sleep-for 1.5) (m-x-run session "run-timer-interactively") diff --git a/tests/cases/sit-for-return-value.el b/tests/cases/sit-for-return-value.el index 7e5d98b..232b81b 100644 --- a/tests/cases/sit-for-return-value.el +++ b/tests/cases/sit-for-return-value.el @@ -41,8 +41,7 @@ ;; driver code (defun run-test () (let ((session (start-test))) - ;; TODO do we need this? - (sleep-for 0.5) + (wait-until-ready session) (m-x-run session "test-sit-for") (sleep-for 3) (m-x-run session "test-sit-for") diff --git a/tests/cases/startup-in-init.el b/tests/cases/startup-in-init.el index 9391d27..4bf97a8 100644 --- a/tests/cases/startup-in-init.el +++ b/tests/cases/startup-in-init.el @@ -67,5 +67,8 @@ if messages buffer has error message." (wait-until-dead session))) (defun finish-test (session) - ;; if we got here we didn't die during check-buffers - (kill-emacs 0)) + (let ((passed 0)) + (message-assert + (equal (nth 5 session) "exit-test-quit-emacs") + "mode installed correctly") + (kill-emacs passed))) diff --git a/tests/cases/timer-y-n-or-p.el b/tests/cases/timer-y-n-or-p.el new file mode 100644 index 0000000..7f34df0 --- /dev/null +++ b/tests/cases/timer-y-n-or-p.el @@ -0,0 +1,87 @@ +;;; -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Lin Xu + +;; Author: Lin Xu +;; Version: 0.1 +;; Created: May 18, 2020 +;; Keywords: performance speed config +;; URL: https://github.com/lastquestion/explain-pause-mode + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Regression test for part of #26. +;;; test that when a timer interrupts a minibuffer with y-or-n-p, +;;; time is subtracted from each other. + +(defun before-test () + t) + +(defun start-interrupt-timer () + (run-with-timer 1 nil 'timer)) + +(defun timer () + (sleep-for 0.1) + (unless (y-or-n-p "question") + (start-interrupt-timer))) + +(defun reader () + (interactive) + (read-from-minibuffer "Some input:") + (sleep-for 0.5)) + +(defun after-test () + t) + +;; driver code +(defun run-test () + (let ((session (start-test))) + (wait-until-ready session) + (eval-expr session "(start-interrupt-timer)") + (sleep-for 0.1) + (m-x-run session "reader") + (sleep-for 1.5) + ;; the yes or no should be open + (send-key session "n") + (sleep-for 2) + (send-key session "y") + ;; now type for the buffer + (sleep-for 0.5) + (send-key session "f!" 'enter) + (sleep-for 0.5) + (call-after-test session) + (wait-until-dead session))) + +(defun finish-test (session) + (let* ((stream (reverse event-stream)) + (reader (span-func stream "reader")) + (timer-1 (span-func-between reader "timer")) + (timer-2 (span-func-between (cons (cddr timer-1) (cdr reader)) "timer")) + (passed 0)) + + (message-assert + (< (exit-measured-time (cadr reader)) 510) + "Minibuffer time subtracted timers and read") + + (message-assert + (< (exit-measured-time (cadr timer-1)) 120) + "timer time subtracted out y-or-n-p time") + + (message-assert + (< (exit-measured-time (cadr timer-2)) 120) + "timer time subtracted out y-or-n-p time") + + (kill-emacs passed))) From 58785b8bde8e12ffb3e62b02b9f5fbf076f62ba6 Mon Sep 17 00:00:00 2001 From: Lin Xu Date: Mon, 29 Jun 2020 02:28:28 -0700 Subject: [PATCH 08/13] Return the original wrapped sentinel/filter function when requested. When we wrap a process filter or sentinel, we end up putting in a lambda into the actual process. If later, `process-filter` is called to get the filter out, eq comparisons that used to work will fail. Store the original callbacks into the process object so we can hijack `process-filter` to return the original. Fixes #46. Originally found from `magit`, in `with-editor`, in `with-editor-set-process-filter`. --- Makefile | 6 +- explain-pause-mode.el | 120 ++++++++++++++++++------ tests/cases/test-process-measurement.el | 92 ++++++++++++++++++ 3 files changed, 184 insertions(+), 34 deletions(-) create mode 100644 tests/cases/test-process-measurement.el diff --git a/Makefile b/Makefile index b877fca..97370a3 100644 --- a/Makefile +++ b/Makefile @@ -12,10 +12,10 @@ cases:=$(filter-out $(case-driver), $(wildcard tests/cases/*.el)) case-tests: $(cases) $(cases): %.el: - emacs --batch -f toggle-debug-on-error -l $(case-driver) -l $@ -f "run-test" + emacs -batch -Q -f toggle-debug-on-error -l $(case-driver) -l $@ -f "run-test" unit-tests: - $(EMACS) -batch -f package-initialize -l explain-pause-mode.el -f buttercup-run-discover tests - $(EMACS) -batch -l explain-pause-mode.el -l tests/manual-test-command-logging.el + $(EMACS) -batch -Q -f package-initialize -l explain-pause-mode.el -f buttercup-run-discover tests + $(EMACS) -batch -Q -l explain-pause-mode.el -l tests/manual-test-command-logging.el tests: unit-tests case-tests diff --git a/explain-pause-mode.el b/explain-pause-mode.el index 66594bb..935349b 100644 --- a/explain-pause-mode.el +++ b/explain-pause-mode.el @@ -2873,6 +2873,7 @@ any." original-filter))) (original-sentinel (plist-get args :sentinel)) + (wrapped-sentinel (when original-sentinel (explain-pause--generate-wrapper @@ -2893,42 +2894,84 @@ any." (when process ;; store the process frame in a process variable so later we can get at it ;; for new filters - (process-put process 'explain-pause-process-frame process-frame)) + (process-put process 'explain-pause-process-frame process-frame) + + ;; store the original filters and sentinels so we can return them out, + ;; if not nil + (when original-filter + (process-put process 'explain-pause-original-filter original-filter)) + (when original-sentinel + (process-put process 'explain-pause-original-sentinel original-sentinel))) + process))) -(defun explain-pause--wrap-set-process-filter-callback (args) - "Advise that modifies the arguments ARGS to `process-filter' by wrapping the -callback." +(defun explain-pause--wrap-set-process-filter-callback (orig &rest args) + "Advise that wraps `set-process-filter' so the callback is wrapped." + ;; be careful to set the saved filter value AFTER the call, so if it + ;; throws, we avoid changing it. (seq-let [arg-process original-callback] args (if (not original-callback) - args - (let ((process-frame (process-get arg-process 'explain-pause-process-frame))) - (list arg-process - (explain-pause--generate-wrapper - ;; the parent of the new record is the original process, NOT - ;; the caller - (explain-pause--command-record-from-parent - process-frame - process-frame - 'process-filter) - original-callback)))))) - -(defun explain-pause--wrap-set-process-sentinel-callback (args) - "Advise that modifies the arguments ARGS to `process-sentinel' by wrapping the -callback." + (let ((result (apply orig args))) + (process-put arg-process 'explain-pause-original-filter nil) + result) + (let* ((process-frame (process-get arg-process 'explain-pause-process-frame)) + (result + (apply orig + (list arg-process + (explain-pause--generate-wrapper + ;; the parent of the new record is the original process, NOT + ;; the caller + (explain-pause--command-record-from-parent + process-frame + process-frame + 'process-filter) + original-callback))))) + (process-put arg-process 'explain-pause-original-filter original-callback) + result)))) + +(defun explain-pause--wrap-set-process-sentinel-callback (orig &rest args) + "Advise that wraps `set-process-sentinel' so the callback is wrapped." + ;; be careful to set the saved sentinel value AFTER the call, so if it + ;; throws, we avoid changing it. (seq-let [arg-process original-callback] args (if (not original-callback) - args - (let ((process-frame (process-get arg-process 'explain-pause-process-frame))) - (list arg-process - (explain-pause--generate-wrapper - ;; the parent of the new record is the original process, NOT - ;; the caller - (explain-pause--command-record-from-parent - process-frame - process-frame - 'process-sentinel) - original-callback)))))) + (let ((result (apply orig args))) + (process-put arg-process 'explain-pause-original-sentinel nil) + result) + (let* ((process-frame (process-get arg-process 'explain-pause-process-frame)) + (result + (apply orig + (list arg-process + (explain-pause--generate-wrapper + ;; the parent of the new record is the original process, NOT + ;; the caller + (explain-pause--command-record-from-parent + process-frame + process-frame + 'process-sentinel) + original-callback))))) + (process-put arg-process 'explain-pause-original-sentinel original-callback) + result)))) + +(defun explain-pause--wrap-get-process-filter (orig &rest args) + "Advise `process-filter' so it returns the unwrapped, original filter, so +comparisions still work." + (let ((original-filter (process-get (car args) 'explain-pause-original-filter))) + ;; it might be nil: a default filter, or the process has not been called with + ;; set-process-filter with our advised callback, e.g. a long lived process + ;; that started before the mode was activated. + (if original-filter + original-filter + (apply orig args)))) + +(defun explain-pause--wrap-get-process-sentinel (orig &rest args) + (let ((original-sentinel (process-get (car args) 'explain-pause-original-sentinel))) + ;; it might be nil: a default filter, or the process has not been called with + ;; set-process-filter with our advised callback, e.g. a long lived process + ;; that started before the mode was activated. + (if original-sentinel + original-sentinel + (apply orig args)))) (defconst explain-pause--timer-frame-max-depth 64 "The maximum depth a record chain for a timer can get.") @@ -3010,7 +3053,10 @@ callback." '( ;; these are functions who setup callbacks which can be wrapped. (run-with-idle-timer . explain-pause--wrap-idle-timer-callback) - (run-with-timer . explain-pause--wrap-timer-callback) + (run-with-timer . explain-pause--wrap-timer-callback))) + (callback-around-family + '( + ;; timing callbacks, but they need around advice. (set-process-filter . explain-pause--wrap-set-process-filter-callback) (set-process-sentinel . explain-pause--wrap-set-process-sentinel-callback))) (make-process-family @@ -3069,9 +3115,15 @@ callback." (advice-add process-func :around #'explain-pause--wrap-make-process)) + (advice-add 'process-filter :around #'explain-pause--wrap-get-process-filter) + (advice-add 'process-sentinel :around #'explain-pause--wrap-get-process-sentinel) + (dolist (callback-func callback-family) (advice-add (car callback-func) :filter-args (cdr callback-func))) + (dolist (callback-func callback-around-family) + (advice-add (car callback-func) :around (cdr callback-func))) + (advice-add 'file-notify-add-watch :filter-args #'explain-pause--wrap-file-notify-add-watch) @@ -3116,6 +3168,12 @@ github.com/lastquestion/explain-pause-mode") (dolist (callback-func callback-family) (advice-remove (car callback-func) (cdr callback-func))) + (dolist (callback-func callback-around-family) + (advice-remove (car callback-func) (cdr callback-func))) + + (advice-remove 'process-filter #'explain-pause--wrap-get-process-filter) + (advice-remove 'process-sentinel #'explain-pause--wrap-get-process-sentinel) + (dolist (process-func make-process-family) (advice-remove process-func #'explain-pause--wrap-make-process)) diff --git a/tests/cases/test-process-measurement.el b/tests/cases/test-process-measurement.el new file mode 100644 index 0000000..1717604 --- /dev/null +++ b/tests/cases/test-process-measurement.el @@ -0,0 +1,92 @@ +;;; -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Lin Xu + +;; Author: Lin Xu +;; Version: 0.1 +;; Created: May 18, 2020 +;; Keywords: performance speed config +;; URL: https://github.com/lastquestion/explain-pause-mode + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; test process measurement + +;; TODO this needs to move to a new folder for tests that need +;; explain-pause-mode loaded but not a full subemacs. +;; TODO needs to test the throw cases +(load-file "./explain-pause-mode.el") + +(defun my-filter (process string) + t) + +(defun my-sentinel (process event) + t) + +(defun it-hides-process-filters () + (let ((passed 0)) + (setq proc (make-process + :name "foo" + :command '("cat") + :buffer nil + :filter nil)) + + (set-process-filter proc 'my-filter) + (set-process-sentinel proc 'my-sentinel) + + (message-assert + (eq (process-filter proc) 'my-filter) + "process-filter returns the original unwrapped filter") + + (message-assert + (eq (process-sentinel proc) 'my-sentinel) + "process-sentinel returns the original unwrapped sentinel") + + (delete-process proc) + + passed)) + +(defun it-works-when-nil-passed () + (let ((passed 0)) + (setq proc (make-process + :name "foo" + :command '("cat") + :buffer nil + :filter nil)) + + (set-process-filter proc nil) + (set-process-sentinel proc nil) + + (message-assert + (eq (process-filter proc) 'internal-default-process-filter) + "process-filter returns internal-default-process-filter when set with nil") + + (message-assert + (eq (process-sentinel proc) 'internal-default-process-sentinel) + "process-sentinel returns internal-default-process-sentinel when set with nil") + + (delete-process proc) + + passed)) + +;; driver code +(defun run-test () + (explain-pause-mode) + (let ((passed + (and (it-hides-process-filters) + (it-works-when-nil-passed)))) + + (kill-emacs passed))) From f55fa50fc5e49dd9c42ad847ff76d0db794bd6be Mon Sep 17 00:00:00 2001 From: Lin Xu Date: Mon, 29 Jun 2020 23:16:14 -0700 Subject: [PATCH 09/13] Advise x-popup-menu; add a test for it. Also pass bytecode warnings. --- explain-pause-mode.el | 5 +- tests/cases/driver.el | 43 ++++++++++---- tests/cases/minibuffer-menu-timer.el | 84 ++++++++++++++++++++++++++++ 3 files changed, 120 insertions(+), 12 deletions(-) create mode 100644 tests/cases/minibuffer-menu-timer.el diff --git a/explain-pause-mode.el b/explain-pause-mode.el index 935349b..702b8ad 100644 --- a/explain-pause-mode.el +++ b/explain-pause-mode.el @@ -315,7 +315,7 @@ in any `explain-pause-top' buffers." (interactive) (clrhash explain-pause-profile--profile-statistics)) -(defun explain-pause-profiles-ignore-command (command-set) +(defun explain-pause-profiles-ignore-command (_command-set) "Ignore this command-set from ever being profiled." ;;TODO (interactive) t) @@ -3074,6 +3074,9 @@ callback." read-char read-char-exclusive read-event + ;; Menu bar function that ultimately calls `read_key_sequence' which + ;; calls `read_char'. + x-popup-menu ;; These C functions ultimately call `read_minibuf' which will call ;; `recursive_edit' (in C), which means they will call ;; `call-interactively' (which we have advised.) diff --git a/tests/cases/driver.el b/tests/cases/driver.el index 42e2dda..55956a7 100644 --- a/tests/cases/driver.el +++ b/tests/cases/driver.el @@ -333,6 +333,13 @@ emacs is running at root of the project." key))))) keys '())) +(defun convert-to-special (key) + (cond + ((eq key 'f10) + "f10") + ((eq key 'quit) + "C-g"))) + (defun convert-to-str (keys) (mapconcat (lambda (key) (cond @@ -344,27 +351,41 @@ emacs is running at root of the project." key))) keys "")) -(defun send-key (session &rest KEYS) - "Send KEYS to tmux session created by `start-test'" - (if wait-keys - (read-from-minibuffer (format "send %s..." KEYS)) - (if verbose - (message "%s %s" - (convert-to-str KEYS) - (convert-to-hex KEYS)) - (send-string-to-terminal "."))) +(defun send-key-stream (session args) + "Actually send a key stream to tmux." (let ((proc (make-process :name "tmux" :buffer nil - :command `("tmux" "send-keys" "-H" "-t" + :command `("tmux" "send-keys" "-t" ,(car session) - ,@(convert-to-hex KEYS)) + ,@args) :connection 'pipe))) (while (process-live-p proc) (when verbose (spinner)) (accept-process-output)))) +(defun send-key (session &rest KEYS) + "Send KEYS to tmux session created by `start-test'" + (when wait-keys + (read-from-minibuffer (format "send %s..." KEYS))) + (if verbose + (message "%s %s" + (convert-to-str KEYS) + (convert-to-hex KEYS)) + (send-string-to-terminal ".")) + (send-key-stream session + (cons "-H" (convert-to-hex KEYS)))) + +(defun send-special-key (session special-key) + "Send either f10 or ctrl-g." + (when wait-keys + (read-from-minibuffer (format "send %s..." special-key))) + (if verbose + (message "%s %s" special-key (convert-to-special special-key)) + (send-string-to-terminal ".")) + (send-key-stream session (cons (convert-to-special special-key) nil))) + (defun m-key-string (session key command) (send-key session 'escape key) (let ((keys (seq-partition command 5))) diff --git a/tests/cases/minibuffer-menu-timer.el b/tests/cases/minibuffer-menu-timer.el new file mode 100644 index 0000000..3e38f0a --- /dev/null +++ b/tests/cases/minibuffer-menu-timer.el @@ -0,0 +1,84 @@ +;;; -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Lin Xu + +;; Author: Lin Xu +;; Version: 0.1 +;; Created: May 18, 2020 +;; Keywords: performance speed config +;; URL: https://github.com/lastquestion/explain-pause-mode + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; test case for #19. Open a minibuffer, then open a menu, while +;;; letting a timer run. Verify that all interleaves do not count +;;; against each other. + +(defun before-test () + t) + +(defun timer-func () + (sleep-for 0.1)) + +(defun run-timer () + (setq sit-timer + (run-with-timer 0.25 1 'timer-func))) + +(defun after-test () + t) + +;; driver code +(defun run-test () + (let ((session (start-test))) + (wait-until-ready session) + (eval-expr session "(run-timer)") + (send-key session 'escape "x") + (send-special-key session 'f10) + (sleep-for 2) + (send-special-key session 'quit) + (sleep-for 0.5) + (send-special-key session 'quit) + (call-after-test session) + (wait-until-dead session))) + +(defun finish-test (session) + (let* ((stream (reverse event-stream)) + (m-x (span-func stream "execute-extended-command")) + (menu-bar-open (span-func-between m-x "menu-bar-open")) + (timer-within-menu-bar (span-func-between menu-bar-open "timer-func")) + (timer-within-minibuffer (span-func-between + (cons (cddr menu-bar-open) + (cdr m-x)) + "timer-func")) + (passed 0)) + + (message-assert + (< (exit-measured-time (cadr m-x)) 10) + "minibuffer subtracted out all time") + + (message-assert + (< (exit-measured-time (cadr menu-bar-open)) 10) + "menu-bar subtracted out all time") + + (message-assert + (< (exit-measured-time (cadr timer-within-menu-bar)) 110) + "timer within menu bar was correctly measured") + + (message-assert + (< (exit-measured-time (cadr timer-within-minibuffer)) 110) + "timer within minibuffer was correctly measured") + + (kill-emacs passed))) From 54dbc2092053265e58309e613e30aebcd04062cc Mon Sep 17 00:00:00 2001 From: Lin Xu Date: Mon, 29 Jun 2020 23:48:49 -0700 Subject: [PATCH 10/13] Make makefile work for any emacs. Reorganize test folder. --- Makefile | 20 ++++++++++++------- tests/cases/driver.el | 5 +++-- .../{ => unit}/manual-test-command-logging.el | 6 +++--- tests/{ => unit}/test-command-logging.el | 0 tests/{ => unit}/test-measurement.el | 0 tests/{ => unit}/test-profile-measurement.el | 0 tests/{ => unit}/test-table.el | 0 tests/{ => unit}/test-top.el | 0 8 files changed, 19 insertions(+), 12 deletions(-) rename tests/{ => unit}/manual-test-command-logging.el (88%) rename tests/{ => unit}/test-command-logging.el (100%) rename tests/{ => unit}/test-measurement.el (100%) rename tests/{ => unit}/test-profile-measurement.el (100%) rename tests/{ => unit}/test-table.el (100%) rename tests/{ => unit}/test-top.el (100%) diff --git a/Makefile b/Makefile index 97370a3..70e9603 100644 --- a/Makefile +++ b/Makefile @@ -1,21 +1,27 @@ -# TODO add multiple emacs versions, don't depend on package-initialize, use -Q - EMACS=emacs # the test case that need full emacs driver case-driver=tests/cases/driver.el cases:=$(filter-out $(case-driver), $(wildcard tests/cases/*.el)) +# root project directory. use absolute paths so we can use any emacs +# note this has a trailing / +ROOT_DIR:=$(dir $(realpath $(lastword $(MAKEFILE_LIST)))) + # all the test cases don't generate output so they need to be PHONY .PHONY: test case-tests $(cases) +print-emacs-version: + @echo $(ROOT_DIR) + @echo "Emacs version under test: " `$(EMACS) --version | head -n 1` + case-tests: $(cases) -$(cases): %.el: - emacs -batch -Q -f toggle-debug-on-error -l $(case-driver) -l $@ -f "run-test" +$(cases): %.el: print-emacs-version + $(EMACS) -batch -Q -f toggle-debug-on-error -l $(case-driver) -l $@ -f "run-test" -unit-tests: - $(EMACS) -batch -Q -f package-initialize -l explain-pause-mode.el -f buttercup-run-discover tests - $(EMACS) -batch -Q -l explain-pause-mode.el -l tests/manual-test-command-logging.el +unit-tests: print-emacs-version + EMACSLOADPATH=$(BUTTERCUP_DIR): $(EMACS) -batch -Q -l explain-pause-mode.el -l buttercup.el -f buttercup-run-discover $(ROOT_DIR)tests/unit + $(EMACS) -batch -Q -l explain-pause-mode.el -l tests/unit/manual-test-command-logging.el tests: unit-tests case-tests diff --git a/tests/cases/driver.el b/tests/cases/driver.el index 55956a7..56d6da7 100644 --- a/tests/cases/driver.el +++ b/tests/cases/driver.el @@ -186,7 +186,8 @@ emacs is running at root of the project." "./tests/cases/driver.el" ))) - (let* ((name (file-name-base filename)) + (let* ((emacs-binary (expand-file-name invocation-name invocation-directory)) + (name (file-name-base filename)) (socket-filename (concat (file-name-directory filename) name "-socket.sock")) @@ -228,7 +229,7 @@ emacs is running at root of the project." (args `("tmux" nil ,name nil "new-session" "-d" "-n" ,name ;; name the session "-P" "-F" "\"#{pane_pid}\"" ;; get us the pid for later - "emacs" + ,emacs-binary ,@emacs-args "-l" ,filename diff --git a/tests/manual-test-command-logging.el b/tests/unit/manual-test-command-logging.el similarity index 88% rename from tests/manual-test-command-logging.el rename to tests/unit/manual-test-command-logging.el index bfe73cc..17747dd 100644 --- a/tests/manual-test-command-logging.el +++ b/tests/unit/manual-test-command-logging.el @@ -32,9 +32,9 @@ " (arg-list: (x y z))") (pass (equal result compare))) (if pass - (message "passed") - (message "lambda is not working in explain-pause--command-as-string: + (message "\e[32mpassed\e[m") + (message "\e[31mlambda is not working in explain-pause--command-as-string: '%s' does not match '%s'. -check tests/manual-test-command-logging" result compare) +check tests/manual-test-command-logging\e[m" result compare) (kill-emacs 1))) diff --git a/tests/test-command-logging.el b/tests/unit/test-command-logging.el similarity index 100% rename from tests/test-command-logging.el rename to tests/unit/test-command-logging.el diff --git a/tests/test-measurement.el b/tests/unit/test-measurement.el similarity index 100% rename from tests/test-measurement.el rename to tests/unit/test-measurement.el diff --git a/tests/test-profile-measurement.el b/tests/unit/test-profile-measurement.el similarity index 100% rename from tests/test-profile-measurement.el rename to tests/unit/test-profile-measurement.el diff --git a/tests/test-table.el b/tests/unit/test-table.el similarity index 100% rename from tests/test-table.el rename to tests/unit/test-table.el diff --git a/tests/test-top.el b/tests/unit/test-top.el similarity index 100% rename from tests/test-top.el rename to tests/unit/test-top.el From 034df20094b4a6312c89781d2db6fd9cd1014998 Mon Sep 17 00:00:00 2001 From: Lin Xu Date: Tue, 30 Jun 2020 20:03:57 -0700 Subject: [PATCH 11/13] Actually pass bytecompile. --- Makefile | 3 + explain-pause-mode.el | 684 +++++++++++++++++++++--------------------- 2 files changed, 350 insertions(+), 337 deletions(-) diff --git a/Makefile b/Makefile index 70e9603..ee0efe2 100644 --- a/Makefile +++ b/Makefile @@ -11,6 +11,9 @@ ROOT_DIR:=$(dir $(realpath $(lastword $(MAKEFILE_LIST)))) # all the test cases don't generate output so they need to be PHONY .PHONY: test case-tests $(cases) +byte-compile: + $(EMACS) -batch -f batch-byte-compile explain-pause-mode.el + print-emacs-version: @echo $(ROOT_DIR) @echo "Emacs version under test: " `$(EMACS) --version | head -n 1` diff --git a/explain-pause-mode.el b/explain-pause-mode.el index 702b8ad..c3454dc 100644 --- a/explain-pause-mode.el +++ b/explain-pause-mode.el @@ -43,6 +43,10 @@ (require 'nadvice) (require 'cl-macs) +;; don't type check. note this only applies when (cl--compiling-file) returns t +;; - e.g. when it's bytecompiled. +(cl-declaim (optimize (safety 0) (speed 3))) + ;; customizable behavior (defgroup explain-pause nil "Explain pauses in Emacs" @@ -162,13 +166,6 @@ buffer." "The face used to indicate the currently sorted column in the header line." :group 'explain-pause-top) -;; time lists are too expensive to create every single call -;; convert to a integer of ms. -(defsubst explain-pause--as-ms-exact (time) - "Returns the TIME object in exact ms, ignoring picoseconds." - (+ (* (+ (* (nth 0 time) 65536) (nth 1 time)) 1000) - (/ (nth 2 time) 1000))) - (defcustom explain-pause-alert-normal-interval 15 "What is the minimum amount of time, in minutes, between alerts when `explain-pause-alert-style' is normal? You can put a fractional value if you @@ -182,6 +179,15 @@ wish." :type 'integer :group 'explain-pause-alerting) +(defvar explain-pause-mode) + +;; time lists are too expensive to create every single call +;; convert to a integer of ms. +(defsubst explain-pause--as-ms-exact (time) + "Returns the TIME object in exact ms, ignoring picoseconds." + (+ (* (+ (* (nth 0 time) 65536) (nth 1 time)) 1000) + (/ (nth 2 time) 1000))) + ;; TODO perhaps this should also display minor modes? probably. minor modes can be interact ;; weirdly and become slow. ;; TODO these aren't used right now @@ -243,6 +249,48 @@ blocking execution (or we think so, anyway)." #'explain-pause--command-as-string command-set ", ")) +;; the record of an command that we measured +;; theorywise, we are constructing a tree of records, all rooted at "emacs command +;; loop". Idealistically, we could maintain this tree and calculate the timings +;; by subtracting child times from our own. But because elisp actually executes +;; only one thing at a time, structure the graph as a stack and pause tracking +;; as we enter / exit by push/popping - we're traversing the graph as DFS +;; as we execute. +(cl-defstruct explain-pause-command-record + ;; the command this tracked + command + ;; was this a native frame + native + ;; the parent + parent + + ;; timing + ;; the number of ms spent so far. + (executing-time 0) + ;; a TIME object as snap + entry-snap + ;; was this too slow + too-slow + + ;; profiling: + ;; was profiling was started FOR this command + is-profiled + ;; was profiling started when this command started + under-profile + ;; the profile if it was + profile + + ;; depth of the callstack so far + depth) + +(defconst explain-pause-root-command-loop + (make-explain-pause-command-record + :command 'root-emacs + :depth 0) + "All command records that `explain-pause' tracks ultimately are rooted to this +command entry, which represents the top level command loop that begins in +`keyboard.c' when called from the initial `recursive_edit' from `emacs.c'.") + ;; profiling and slow statistics functions ;; TODO :equal list command (defvar explain-pause-profile--profile-statistics (make-hash-table) @@ -340,85 +388,86 @@ in any `explain-pause-top' buffers." (setf new-stat default-stat)) (puthash command statistic explain-pause-profile--profile-statistics)))) -(let ((profile nil) - (statistic nil) - (command nil) - (slow-index nil)) +(eval-and-compile ;; for the mainline case, no profiles are stored but values are incremented ;; store these outside in a closure, so we don't need to create lets every call. - (defun explain-pause-profile--profile-measured-command (record) - "Record the statistics for this command. + (let ((profile nil) + (statistic nil) + (command nil) + (slow-index nil)) + (defun explain-pause-profile--profile-measured-command (record) + "Record the statistics for this command. Always store the slowness. If profiling is on, store the profiling counts. Store the profile if it was profiled." - (unless (explain-pause-command-record-native record) - (cond - ;; did we try to profile but it was too fast? if this happens more - ;; then threshold times, reset the counter back to 0 - ((and (explain-pause-command-record-is-profiled record) - (not (explain-pause-command-record-too-slow record))) - - (explain-pause-profile--profile-get-statistic record) - - ;; reuse profile var for attempt counter - (setq profile (aref statistic 2)) - (if (< profile explain-pause-profile-saved-profiles) - (setf (aref statistic 2) (1+ profile)) - ;; give up TODO force? - (setf (aref statistic 0) 0) - (setf (aref statistic 1) nil) - (setf (aref statistic 2) 0))) - - ((explain-pause-command-record-too-slow record) - ;; otherwise, if we're too slow... - (explain-pause-profile--profile-get-statistic record) - (setq profile (explain-pause-command-record-profile record)) - - ;; increment the slow count - (setf (aref statistic 4) (1+ (aref statistic 4))) - - ;; save the ms into the circular list - (setq slow-index (or (aref statistic 5) 0)) - (setf (aref statistic (+ slow-index - explain-pause-profile--statistic-slow-count-offset)) - (explain-pause-command-record-executing-time record)) - ;; increment slow-ms-index to the next place - (setf (aref statistic 5) - (% (1+ slow-index) - ;; don't use `explain-pause-profile-saved-profiles' because the value - ;; might have changed - (explain-pause-profile--statistic-slow-length statistic))) - + (unless (explain-pause-command-record-native record) (cond - ;; add the profile if it exists. - ;; we assume that profiles happen relatively rarely, so it's ok to use - ;; a list so that 'eq comparisons work against head: - (profile - (let ((head (aref statistic 3)) - (new-entry (vector - (explain-pause-command-record-executing-time record) - profile))) - - (setf (aref statistic 3) - (if (< (length head) - explain-pause-profile-saved-profiles) - (cons new-entry head) - ;; need to make a duplicate list - (cons new-entry - (seq-take head - (- explain-pause-profile-saved-profiles 1)))))) - - ;; reset for next time - (setf (aref statistic 0) 0) - (setf (aref statistic 1) nil)) - (t - ;; reuse profile var for the counter here - (setq profile (aref statistic 0)) - (when (>= profile 0) ;; only increment for "non-special" counts - (setq profile (1+ profile)) - (setf (aref statistic 0) profile) - (setf (aref statistic 1) - (>= profile explain-pause-profile-slow-threshold)))))))))) + ;; did we try to profile but it was too fast? if this happens more + ;; then threshold times, reset the counter back to 0 + ((and (explain-pause-command-record-is-profiled record) + (not (explain-pause-command-record-too-slow record))) + + (explain-pause-profile--profile-get-statistic record) + + ;; reuse profile var for attempt counter + (setq profile (aref statistic 2)) + (if (< profile explain-pause-profile-saved-profiles) + (setf (aref statistic 2) (1+ profile)) + ;; give up TODO force? + (setf (aref statistic 0) 0) + (setf (aref statistic 1) nil) + (setf (aref statistic 2) 0))) + + ((explain-pause-command-record-too-slow record) + ;; otherwise, if we're too slow... + (explain-pause-profile--profile-get-statistic record) + (setq profile (explain-pause-command-record-profile record)) + + ;; increment the slow count + (setf (aref statistic 4) (1+ (aref statistic 4))) + + ;; save the ms into the circular list + (setq slow-index (or (aref statistic 5) 0)) + (setf (aref statistic (+ slow-index + explain-pause-profile--statistic-slow-count-offset)) + (explain-pause-command-record-executing-time record)) + ;; increment slow-ms-index to the next place + (setf (aref statistic 5) + (% (1+ slow-index) + ;; don't use `explain-pause-profile-saved-profiles' because the value + ;; might have changed + (explain-pause-profile--statistic-slow-length statistic))) + + (cond + ;; add the profile if it exists. + ;; we assume that profiles happen relatively rarely, so it's ok to use + ;; a list so that 'eq comparisons work against head: + (profile + (let ((head (aref statistic 3)) + (new-entry (vector + (explain-pause-command-record-executing-time record) + profile))) + + (setf (aref statistic 3) + (if (< (length head) + explain-pause-profile-saved-profiles) + (cons new-entry head) + ;; need to make a duplicate list + (cons new-entry + (seq-take head + (- explain-pause-profile-saved-profiles 1)))))) + + ;; reset for next time + (setf (aref statistic 0) 0) + (setf (aref statistic 1) nil)) + (t + ;; reuse profile var for the counter here + (setq profile (aref statistic 0)) + (when (>= profile 0) ;; only increment for "non-special" counts + (setq profile (1+ profile)) + (setf (aref statistic 0) profile) + (setf (aref statistic 1) + (>= profile explain-pause-profile-slow-threshold))))))))))) ;; table functions ;; I tried to use `tabulated-list' as well as `ewoc' but I decided to implement @@ -427,10 +476,6 @@ Store the profile if it was profiled." ;; part of it is already abstracted out into something close to reusable, but ;; other parts are not yet. -;; don't type check. note this only applies when (cl--compiling-file) returns t -;; - e.g. when it's bytecompiled. -(cl-declaim (optimize (safety 0) (speed 3))) - (cl-defstruct explain-pause-top--table ;; the list of entries to display, in sorted order ;; (item prev-display-ptr) @@ -1295,48 +1340,6 @@ the width cannot be 0." (setf (explain-pause-top--table-buffer-index table) prev-buffer-index) (setf (explain-pause-top--table-prev-buffer-index table) buffer-index))) -;; the record of an command that we measured -;; theorywise, we are constructing a tree of records, all rooted at "emacs command -;; loop". Idealistically, we could maintain this tree and calculate the timings -;; by subtracting child times from our own. But because elisp actually executes -;; only one thing at a time, structure the graph as a stack and pause tracking -;; as we enter / exit by push/popping - we're traversing the graph as DFS -;; as we execute. -(cl-defstruct explain-pause-command-record - ;; the command this tracked - command - ;; was this a native frame - native - ;; the parent - parent - - ;; timing - ;; the number of ms spent so far. - (executing-time 0) - ;; a TIME object as snap - entry-snap - ;; was this too slow - too-slow - - ;; profiling: - ;; was profiling was started FOR this command - is-profiled - ;; was profiling started when this command started - under-profile - ;; the profile if it was - profile - - ;; depth of the callstack so far - depth) - -(defconst explain-pause-root-command-loop - (make-explain-pause-command-record - :command 'root-emacs - :depth 0) - "All command records that `explain-pause' tracks ultimately are rooted to this -command entry, which represents the top level command loop that begins in -`keyboard.c' when called from the initial `recursive_edit' from `emacs.c'.") - ;; explain-pause-top-mode ;; buffer-local variables that should be always private (defvar-local explain-pause-top--buffer-refresh-timer nil @@ -1723,78 +1726,79 @@ within 15 minutes of the last time an alert was shown; or (when new-hook (add-hook 'explain-pause-measured-command-hook (cdr new-hook)))))) -(let ((notification-count 0) - (last-notified (current-time)) - (alert-timer nil)) - (defun explain-pause-mode--log-alert-normal (record) - "Notify the user of alerts when at least `explain-pause-alert-normal-minimum-count' +(eval-and-compile + (let ((notification-count 0) + (last-notified (current-time)) + (alert-timer nil)) + (defun explain-pause-mode--log-alert-normal (record) + "Notify the user of alerts when at least `explain-pause-alert-normal-minimum-count' alerts have occurred, AND the time since the last notification (or startup) is greater then `explain-pause-alert-normal-interval' minutes." - (when (and (not (explain-pause-command-record-native record)) - (explain-pause-command-record-too-slow record)) - (setq notification-count (1+ notification-count)) - (when (and (>= notification-count explain-pause-alert-normal-minimum-count) - (> (float-time (time-subtract nil last-notified)) - (* explain-pause-alert-normal-interval 60)) - (not alert-timer)) - (setq alert-timer - (run-with-idle-timer 1 nil - #'explain-pause-mode--log-alert-normal-display))))) - - (defun explain-pause-mode--log-alert-normal-display () - "Display the normal alert to the user but only if the minibuffer is not + (when (and (not (explain-pause-command-record-native record)) + (explain-pause-command-record-too-slow record)) + (setq notification-count (1+ notification-count)) + (when (and (>= notification-count explain-pause-alert-normal-minimum-count) + (> (float-time (time-subtract nil last-notified)) + (* explain-pause-alert-normal-interval 60)) + (not alert-timer)) + (setq alert-timer + (run-with-idle-timer 1 nil + #'explain-pause-mode--log-alert-normal-display))))) + + (defun explain-pause-mode--log-alert-normal-display () + "Display the normal alert to the user but only if the minibuffer is not active. If it is open, do nothing; at some point later, the conditions will fire again and this timer will be called again." - (setq alert-timer nil) - ;; if we are not actively in the minibuffer, display our message - (when (not (minibufferp (current-buffer))) - (message "Emacs was slow %d times recently. Run `explain-pause-top' to learn more." notification-count) - (setq notification-count 0) - (setq last-notified (current-time))))) - -(let ((notifications '()) - (profiled-count 0) - (alert-timer nil)) - (defun explain-pause-mode--log-alert-developer (record) - "Log all slow and profiling alerts in developer mode. They are gathered until + (setq alert-timer nil) + ;; if we are not actively in the minibuffer, display our message + (when (not (minibufferp (current-buffer))) + (message "Emacs was slow %d times recently. Run `explain-pause-top' to learn more." notification-count) + (setq notification-count 0) + (setq last-notified (current-time))))) + + (let ((notifications '()) + (profiled-count 0) + (alert-timer nil)) + (defun explain-pause-mode--log-alert-developer (record) + "Log all slow and profiling alerts in developer mode. They are gathered until run-with-idle-timer allows an idle timer to run, and then they are printed to the minibuffer with a 2 second sit-for." - (when (and (not (explain-pause-command-record-native record)) - (explain-pause-command-record-too-slow record)) - (push (explain-pause-command-record-executing-time record) notifications) - (when (explain-pause-command-record-profile record) - (setq profiled-count (1+ profiled-count))) - (unless alert-timer - (setq alert-timer - (run-with-idle-timer - 0.5 nil - #'explain-pause-mode--log-alert-developer-display))))) - - (defun explain-pause-mode--log-alert-developer-display () - "Display the last set of notifications in the echo area when the minibuffer is + (when (and (not (explain-pause-command-record-native record)) + (explain-pause-command-record-too-slow record)) + (push (explain-pause-command-record-executing-time record) notifications) + (when (explain-pause-command-record-profile record) + (setq profiled-count (1+ profiled-count))) + (unless alert-timer + (setq alert-timer + (run-with-idle-timer + 0.5 nil + #'explain-pause-mode--log-alert-developer-display))))) + + (defun explain-pause-mode--log-alert-developer-display () + "Display the last set of notifications in the echo area when the minibuffer is not active." - (if (minibufferp (current-buffer)) - ;; try again - (setq alert-timer - (run-with-idle-timer - (time-add (current-idle-time) 0.5) - nil - #'explain-pause-mode--log-alert-developer-display)) - ;; ok, let's draw - (message "Emacs was slow: %s ms%s%s" - (mapconcat #'number-to-string notifications ", ") - (if (> profiled-count 0) - (format " of which %d were profiled" profiled-count) - "") - ". Run `explain-pause-top' to learn more.") - - ;; reset so more notifications can pile up while we wait - (setq notifications '()) - (setq profiled-count 0) - (sit-for 2) - (message nil) - ;; don't let us get rescheduled until we're really done. - (setq alert-timer nil)))) + (if (minibufferp (current-buffer)) + ;; try again + (setq alert-timer + (run-with-idle-timer + (time-add (current-idle-time) 0.5) + nil + #'explain-pause-mode--log-alert-developer-display)) + ;; ok, let's draw + (message "Emacs was slow: %s ms%s%s" + (mapconcat #'number-to-string notifications ", ") + (if (> profiled-count 0) + (format " of which %d were profiled" profiled-count) + "") + ". Run `explain-pause-top' to learn more.") + + ;; reset so more notifications can pile up while we wait + (setq notifications '()) + (setq profiled-count 0) + (sit-for 2) + (message nil) + ;; don't let us get rescheduled until we're really done. + (setq alert-timer nil))))) ;; logging customization ;; depressingly can't define it at the top because `explain-pause-mode-change-alert-style' @@ -3049,153 +3053,160 @@ callback." 'timer) ,@(seq-drop args 2))) -(let ((callback-family - '( - ;; these are functions who setup callbacks which can be wrapped. - (run-with-idle-timer . explain-pause--wrap-idle-timer-callback) - (run-with-timer . explain-pause--wrap-timer-callback))) - (callback-around-family - '( - ;; timing callbacks, but they need around advice. - (set-process-filter . explain-pause--wrap-set-process-filter-callback) - (set-process-sentinel . explain-pause--wrap-set-process-sentinel-callback))) - (make-process-family - ;; These C functions start async processes, which raise callbacks - ;; `filter' and `sentinel'. Wrap those. - '(make-process - make-pipe-process - make-network-process)) - (native - '( - ;; These C functions ultimately call `read_char' which will run timers, - ;; redisplay, and call `sit_for'. - read-key-sequence - read-key-sequence-vector - read-char - read-char-exclusive - read-event - ;; Menu bar function that ultimately calls `read_key_sequence' which - ;; calls `read_char'. - x-popup-menu - ;; These C functions ultimately call `read_minibuf' which will call - ;; `recursive_edit' (in C), which means they will call - ;; `call-interactively' (which we have advised.) - ;; read-from-minibuffer -> read_minibuf - ;; read-string -> Fread_from_minibuffer -> read_minibuf - ;; read-no-blanks-input -> read_minibuf - read-from-minibuffer - read-string - read-no-blanks-input)) - (completing-read-family - '( - ;; These C functions ultimately call `completing_read' which will - ;; call `completing-read-function'. - read-command - read-function - read-variable - completing-read)) - (install-attempt 0)) - - (defun explain-pause-mode--install-hooks () - "Actually install hooks for `explain-pause-mode'." - (advice-add 'call-interactively :around - #'explain-pause--wrap-call-interactively) - (advice-add 'funcall-interactively :before - #'explain-pause--before-funcall-interactively) - - ;; OK, we're prepared to advise native functions and timers: - (dolist (native-func native) - (advice-add native-func :around - #'explain-pause--wrap-native)) - - (dolist (completing-read-func completing-read-family) - (advice-add completing-read-func :around - #'explain-pause--wrap-completing-read-family)) - - (advice-add 'read-buffer :around #'explain-pause--wrap-read-buffer) - - (dolist (process-func make-process-family) - (advice-add process-func :around - #'explain-pause--wrap-make-process)) - - (advice-add 'process-filter :around #'explain-pause--wrap-get-process-filter) - (advice-add 'process-sentinel :around #'explain-pause--wrap-get-process-sentinel) - - (dolist (callback-func callback-family) - (advice-add (car callback-func) :filter-args (cdr callback-func))) - - (dolist (callback-func callback-around-family) - (advice-add (car callback-func) :around (cdr callback-func))) - - (advice-add 'file-notify-add-watch :filter-args - #'explain-pause--wrap-file-notify-add-watch) - - (setq explain-pause--current-command-record - explain-pause-root-command-loop) - - (when explain-pause-log--send-process - (explain-pause-log--send-dgram - "(\"enabled\")\n")) - - (message "Explain-pause-mode enabled.")) - - (defun explain-pause-mode--enable-hooks () - "Install hooks for `explain-pause-mode' if it is being run at the top of the +(eval-and-compile + (let ((callback-family + '( + ;; these are functions who setup callbacks which can be wrapped. + (run-with-idle-timer . explain-pause--wrap-idle-timer-callback) + (run-with-timer . explain-pause--wrap-timer-callback))) + (callback-around-family + '( + ;; timing callbacks, but they need around advice. + (set-process-filter . explain-pause--wrap-set-process-filter-callback) + (set-process-sentinel . explain-pause--wrap-set-process-sentinel-callback))) + (make-process-family + ;; These C functions start async processes, which raise callbacks + ;; `filter' and `sentinel'. Wrap those. + '(make-process + make-pipe-process + make-network-process)) + (native + '( + ;; These C functions ultimately call `read_char' which will run timers, + ;; redisplay, and call `sit_for'. + read-key-sequence + read-key-sequence-vector + read-char + read-char-exclusive + read-event + ;; Menu bar function that ultimately calls `read_key_sequence' which + ;; calls `read_char'. + x-popup-menu + ;; These C functions ultimately call `read_minibuf' which will call + ;; `recursive_edit' (in C), which means they will call + ;; `call-interactively' (which we have advised.) + ;; read-from-minibuffer -> read_minibuf + ;; read-string -> Fread_from_minibuffer -> read_minibuf + ;; read-no-blanks-input -> read_minibuf + read-from-minibuffer + read-string + read-no-blanks-input)) + (completing-read-family + '( + ;; These C functions ultimately call `completing_read' which will + ;; call `completing-read-function'. + read-command + read-function + read-variable + completing-read)) + (install-attempt 0)) + + (defun explain-pause-mode--install-hooks () + "Actually install hooks for `explain-pause-mode'." + (advice-add 'call-interactively :around + #'explain-pause--wrap-call-interactively) + (advice-add 'funcall-interactively :before + #'explain-pause--before-funcall-interactively) + + ;; OK, we're prepared to advise native functions and timers: + (dolist (native-func native) + (advice-add native-func :around + #'explain-pause--wrap-native)) + + (dolist (completing-read-func completing-read-family) + (advice-add completing-read-func :around + #'explain-pause--wrap-completing-read-family)) + + (advice-add 'read-buffer :around #'explain-pause--wrap-read-buffer) + + (dolist (process-func make-process-family) + (advice-add process-func :around + #'explain-pause--wrap-make-process)) + + (advice-add 'process-filter :around #'explain-pause--wrap-get-process-filter) + (advice-add 'process-sentinel :around #'explain-pause--wrap-get-process-sentinel) + + (dolist (callback-func callback-family) + (advice-add (car callback-func) :filter-args (cdr callback-func))) + + (dolist (callback-func callback-around-family) + (advice-add (car callback-func) :around (cdr callback-func))) + + (advice-add 'file-notify-add-watch :filter-args + #'explain-pause--wrap-file-notify-add-watch) + + (setq explain-pause--current-command-record + explain-pause-root-command-loop) + + (when explain-pause-log--send-process + (explain-pause-log--send-dgram + "(\"enabled\")\n")) + + (message "Explain-pause-mode enabled.")) + + (defun explain-pause-mode--try-enable-hooks () + "Attempt to install `explain-pause-mode' hooks on next post-command-hook +run." + (setq install-attempt 0) + (add-hook 'post-command-hook #'explain-pause-mode--enable-hooks)) + + (defun explain-pause-mode--enable-hooks () + "Install hooks for `explain-pause-mode' if it is being run at the top of the emacs loop, e.g. not inside `call-interactively' or `sit-for' or any interleaved timers, etc. Otherwise, wait for next invocation." - (if (> install-attempt 5) - (progn - (remove-hook 'post-command-hook #'explain-pause-mode--enable-hooks) - (message "Unable to install `explain-pause-mode', please report a bug to \ + (if (> install-attempt 5) + (progn + (remove-hook 'post-command-hook #'explain-pause-mode--enable-hooks) + (message "Unable to install `explain-pause-mode', please report a bug to \ github.com/lastquestion/explain-pause-mode") - (setq explain-pause-mode nil)) - (let ((top-of-loop t)) - (mapbacktrace (lambda (_evaled func _args _flags) - (unless (eq func 'explain-pause-mode--enable-hooks) - (setq top-of-loop nil))) - #'explain-pause-mode--enable-hooks) - (if (not top-of-loop) - (unless (active-minibuffer-window) - ;; well, it's definitely not going to work if the user is got - ;; a minibuffer open. wait until the minibuffer goes away. - (setq install-attempt (1+ install-attempt))) - ;; ok, we're safe: - (remove-hook 'post-command-hook #'explain-pause-mode--enable-hooks) - (explain-pause-mode--install-hooks))))) - - (defun explain-pause-mode--disable-hooks () - "Disable hooks installed by `explain-pause-mode--install-hooks'." - (advice-remove 'file-notify-add-watch - #'explain-pause--wrap-file-notify-add-watch) - - (dolist (callback-func callback-family) - (advice-remove (car callback-func) (cdr callback-func))) - - (dolist (callback-func callback-around-family) - (advice-remove (car callback-func) (cdr callback-func))) - - (advice-remove 'process-filter #'explain-pause--wrap-get-process-filter) - (advice-remove 'process-sentinel #'explain-pause--wrap-get-process-sentinel) - - (dolist (process-func make-process-family) - (advice-remove process-func - #'explain-pause--wrap-make-process)) - - (advice-remove 'read-buffer #'explain-pause--wrap-read-buffer) - - (dolist (completing-read-func completing-read-family) - (advice-remove completing-read-func - #'explain-pause--wrap-completing-read-family)) - - (dolist (native-func native) - (advice-remove native-func - #'explain-pause--wrap-native)) - - (advice-remove 'call-interactively - #'explain-pause--wrap-call-interactively) - - (advice-remove 'funcall-interactively - #'explain-pause--before-funcall-interactively))) + (setq explain-pause-mode nil)) + (let ((top-of-loop t)) + (mapbacktrace (lambda (_evaled func _args _flags) + (unless (eq func 'explain-pause-mode--enable-hooks) + (setq top-of-loop nil))) + #'explain-pause-mode--enable-hooks) + (if (not top-of-loop) + (unless (active-minibuffer-window) + ;; well, it's definitely not going to work if the user is got + ;; a minibuffer open. wait until the minibuffer goes away. + (setq install-attempt (1+ install-attempt))) + ;; ok, we're safe: + (remove-hook 'post-command-hook #'explain-pause-mode--enable-hooks) + (explain-pause-mode--install-hooks))))) + + (defun explain-pause-mode--disable-hooks () + "Disable hooks installed by `explain-pause-mode--install-hooks'." + (advice-remove 'file-notify-add-watch + #'explain-pause--wrap-file-notify-add-watch) + + (dolist (callback-func callback-family) + (advice-remove (car callback-func) (cdr callback-func))) + + (dolist (callback-func callback-around-family) + (advice-remove (car callback-func) (cdr callback-func))) + + (advice-remove 'process-filter #'explain-pause--wrap-get-process-filter) + (advice-remove 'process-sentinel #'explain-pause--wrap-get-process-sentinel) + + (dolist (process-func make-process-family) + (advice-remove process-func + #'explain-pause--wrap-make-process)) + + (advice-remove 'read-buffer #'explain-pause--wrap-read-buffer) + + (dolist (completing-read-func completing-read-family) + (advice-remove completing-read-func + #'explain-pause--wrap-completing-read-family)) + + (dolist (native-func native) + (advice-remove native-func + #'explain-pause--wrap-native)) + + (advice-remove 'call-interactively + #'explain-pause--wrap-call-interactively) + + (advice-remove 'funcall-interactively + #'explain-pause--before-funcall-interactively)))) ;;;###autoload (define-minor-mode explain-pause-mode @@ -3241,8 +3252,7 @@ must install itself after some time while Emacs is not doing anything." (add-hook 'emacs-startup-hook #'explain-pause-mode--enable-hooks) ;; no, then we better run after the next command, which we hope ;; is top level. - (setq install-attempt 0) - (add-hook 'post-command-hook #'explain-pause-mode--enable-hooks)))) + (explain-pause-mode--try-enable-hooks)))) (t (explain-pause-mode--disable-hooks)))) From 772de98ba51015e85ba601b5e434bdd1318e16a0 Mon Sep 17 00:00:00 2001 From: Lin Xu Date: Fri, 3 Jul 2020 10:18:34 -0700 Subject: [PATCH 12/13] Support recursive edit, improve install check, fix TODO for log full --- explain-pause-mode.el | 19 +++-- tests/cases/install-with-recursive-edit.el | 70 ++++++++++++++++ tests/cases/recursive-edit-timer.el | 97 ++++++++++++++++++++++ 3 files changed, 179 insertions(+), 7 deletions(-) create mode 100644 tests/cases/install-with-recursive-edit.el create mode 100644 tests/cases/recursive-edit-timer.el diff --git a/explain-pause-mode.el b/explain-pause-mode.el index c3454dc..19b7faa 100644 --- a/explain-pause-mode.el +++ b/explain-pause-mode.el @@ -2290,8 +2290,10 @@ represent the push and pop indices. Reserve one empty slot to differentiate empty and full.") (defun explain-pause-log--missing-socket-disable () - ;;TODO - (debug)) + (explain-pause-log-off) + (message "Explain-pause-mode stopped logging to socket. It got too full.") + (sit-for 2) + (message nil)) (defsubst explain-pause-log--send-dgram (str) "Write to the socket if it is enabled. The DGRAM code has its own special @@ -3090,7 +3092,10 @@ callback." ;; read-no-blanks-input -> read_minibuf read-from-minibuffer read-string - read-no-blanks-input)) + read-no-blanks-input + ;; recursive edit ultimately calls `command-loop' and unwinds out + ;; either to the call site or to top level + recursive-edit)) (completing-read-family '( ;; These C functions ultimately call `completing_read' which will @@ -3157,7 +3162,7 @@ timers, etc. Otherwise, wait for next invocation." (if (> install-attempt 5) (progn (remove-hook 'post-command-hook #'explain-pause-mode--enable-hooks) - (message "Unable to install `explain-pause-mode', please report a bug to \ + (message "Unable to install `explain-pause-mode'. please report a bug to \ github.com/lastquestion/explain-pause-mode") (setq explain-pause-mode nil)) (let ((top-of-loop t)) @@ -3166,9 +3171,9 @@ github.com/lastquestion/explain-pause-mode") (setq top-of-loop nil))) #'explain-pause-mode--enable-hooks) (if (not top-of-loop) - (unless (active-minibuffer-window) - ;; well, it's definitely not going to work if the user is got - ;; a minibuffer open. wait until the minibuffer goes away. + (when (eq 0 (recursion-depth)) + ;; well, it won't work until the user gets out of that... + ;; ignore commands until we're out of recursive edits (setq install-attempt (1+ install-attempt))) ;; ok, we're safe: (remove-hook 'post-command-hook #'explain-pause-mode--enable-hooks) diff --git a/tests/cases/install-with-recursive-edit.el b/tests/cases/install-with-recursive-edit.el new file mode 100644 index 0000000..e4d07c9 --- /dev/null +++ b/tests/cases/install-with-recursive-edit.el @@ -0,0 +1,70 @@ +;;; -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Lin Xu + +;; Author: Lin Xu +;; Version: 0.1 +;; Created: May 18, 2020 +;; Keywords: performance speed config +;; URL: https://github.com/lastquestion/explain-pause-mode + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Test that when you start up interactively, and you're in a +;;; recursive edit, we wait until you exit before trying to install + +(defun before-test () + t) + +(defun start-mode () + (interactive) + (run-with-idle-timer 0.5 nil 'explain-pause-mode) + (recursive-edit)) + +(defun after-test () + t) + +(defun run-test () + (setq session (start-test + nil + nil + '("-f" "setup-test"))) + + (sleep-for 0.5) + + (m-x-run session "start-mode") + + ;; wait long enough for the idle timer to try + (sleep-for 0.7) + + ;; more then 5, which is the give up number + (send-key session "abcdef") + + ;; ok, get out of recursive + (m-x-run session "abort-recursive-edit") + + ;; install + (send-key session 'enter) + + (call-after-test session) + (wait-until-dead session)) + +(defun finish-test (session) + (let ((passed 0)) + (message-assert + (equal (nth 5 session) "exit-test-quit-emacs") + "mode installed correctly") + (kill-emacs passed))) diff --git a/tests/cases/recursive-edit-timer.el b/tests/cases/recursive-edit-timer.el new file mode 100644 index 0000000..b130ab7 --- /dev/null +++ b/tests/cases/recursive-edit-timer.el @@ -0,0 +1,97 @@ +;;; -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Lin Xu + +;; Author: Lin Xu +;; Version: 0.1 +;; Created: May 18, 2020 +;; Keywords: performance speed config +;; URL: https://github.com/lastquestion/explain-pause-mode + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; test case for #47 +;; run a timer that spans the recursive edit, and takes time. +;; make sure the time subtracted from the call for both sides. +;; make sure we unwind with both abort and exit. + +(defun before-test () + t) + +(defun after-test () + t) + +(defun test-recurse () + (interactive) + (let ((proc (run-with-timer 0.5 0.5 'timer))) + (recursive-edit) + (sleep-for 0.25) + (cancel-timer proc))) + +(defun timer () + (sleep-for 0.01)) + +;; driver code +(defun run-test () + (let ((session (start-test))) + (wait-until-ready session) + (m-x-run session "test-recurse") + (sleep-for 1.5) ;; at least one run inside recursive + (send-key session "hi") + (m-x-run session "exit-recursive-edit") + (sleep-for 1) + (m-x-run session "test-recurse") + (sleep-for 1.5) + (m-x-run session "abort-recursive-edit") + (sleep-for 0.5) + (call-after-test session) + (wait-until-dead session))) + +(defun finish-test (session) + (let* ((stream (reverse event-stream)) + (first-recurse (span-func stream "test-recurse")) + (second-recurse (span-func-between + (cons + (cddr first-recurse) + (cdr session)) + "test-recurse")) + (timers-first-recurse (span-func-between first-recurse "timer")) + (timers-second-recurse (span-func-between second-recurse "timer")) + (first-recurse-time (exit-measured-time (cadr first-recurse))) + (second-recurse-time (exit-measured-time (cadr second-recurse))) + (timers-first-time (exit-measured-time (cadr timers-first-recurse))) + (timers-second-time (exit-measured-time (cadr timers-second-recurse))) + (passed 0)) + + (message-assert + (and (< first-recurse-time 275) + (> first-recurse-time 250)) + "recursive-edit time does not include editing or timers with exit") + + (message-assert + (< timers-first-time 15) + "timers were measured correctly inside recursive edit") + + (message-assert + (and (< first-recurse-time 275) + (> first-recurse-time 250)) + "recursive-edit time does not include editing or timers with quit") + + (message-assert + (< timers-second-time 15) + "timers were measured correctly inside recursive edit") + + (kill-emacs passed))) From ae1d673924c1b44b28f5e30beb84181525d23c65 Mon Sep 17 00:00:00 2001 From: Lin Xu Date: Fri, 3 Jul 2020 11:30:56 -0700 Subject: [PATCH 13/13] fix bytecompile warning by moving install of hook inside enable --- explain-pause-mode.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/explain-pause-mode.el b/explain-pause-mode.el index 19b7faa..adccba9 100644 --- a/explain-pause-mode.el +++ b/explain-pause-mode.el @@ -133,8 +133,6 @@ These commands must be fast, because this hook is executed on every command, not just slow commands. You cannot give up execution in these commands in any way, e.g. do not call any family of functions that `sit-for', `read-key', etc. etc.") -(add-hook 'explain-pause-measured-command-hook - #'explain-pause-profile--profile-measured-command) ;; custom faces (defface explain-pause-top-slow @@ -3143,6 +3141,9 @@ callback." (setq explain-pause--current-command-record explain-pause-root-command-loop) + (add-hook 'explain-pause-measured-command-hook + #'explain-pause-profile--profile-measured-command) + (when explain-pause-log--send-process (explain-pause-log--send-dgram "(\"enabled\")\n"))