Skip to content

Commit

Permalink
Suggest a number of changes
Browse files Browse the repository at this point in the history
  • Loading branch information
@phikal
phikal committed May 28, 2021
1 parent 5169dd7 commit 2837814
Show file tree
Hide file tree
Showing 2 changed files with 148 additions and 293 deletions.
251 changes: 77 additions & 174 deletions esup-child.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -35,55 +35,18 @@
;;; Code:

(require 'benchmark)
(require 'eieio)
(require 'seq)
(require 'subr-x)

;; We don't use :accesssor for class slots because it cause a
;; byte-compiler error even if we use the accessor. This is fixed in
;; Emacs 25. The error text is below:
;;
;; Unused lexical variable `scoped-class'
(defclass esup-result ()
((file :initarg :file
:initform ""
:type string
:documentation "The file location for the result.")
(start-point :initarg :start-point
:initform 1
:type number
:documentation
"The start position of the benchmarked expression.")
(line-number :initarg :line-number
:initform 1
:type number
:documentation "The beginning line number of the expression.")
(expression-string :initarg :expression-string
:initform ""
:type string
:documentation
"A string representation of the benchmarked expression.")
(end-point :initarg :end-point
:initform 0
:type number
:documentation "The end position of the benchmarked expression.")
(exec-time :initarg :exec-time
:initform 0
:type number
:documentation)
(gc-number :initarg :gc-number
:initform 0
:type number
:documentation "The number of garbage collections that ran.")
(gc-time :initarg :gc-time
:initform 0
:type number
:documentation "The time taken by garbage collection.")
(percentage :initarg :percentage
:initform 0
:type number
:documentation "The percentage of time taken by expression."))
"A record of benchmarked results.")
(eval-when-compile (require 'cl-lib))

(cl-defstruct esup-result
(file "" :type 'string)
(start-point 0 :type 'number)
(line-number 0 :type 'number)
(expression-string "" :type 'string)
(end-point 0 :type 'number)
(exec-time 0 :type 'number)
(gc-number 0 :type 'number)
(gc-time 0 :type 'number)
(percentage 0 :type 'number))

(defvar esup-child-max-depth 1
"How deep to profile (require) statements.
Expand Down Expand Up @@ -111,13 +74,6 @@ network process.")
We send our results back to the parent Emacs via this network
process.")

(defvar esup-child-result-separator "\n;;ESUP-RESULT-SEPARATOR;;\n"
"The separator between results.
The parent Emacs uses the separator to know when the child has
sent a full result. Emacs accepts network input only when it's
not busy and in bunches of about 500 bytes. So, we might not get
a complete result.")

(defun esup-child-connect-to-parent (port)
"Connect to the parent process at PORT."
(let ((port-num (if (stringp port) (string-to-number port) port)))
Expand All @@ -140,15 +96,10 @@ a complete result.")
(process-send-string esup-child-parent-log-process
(apply 'format (concat "LOG: " format-str "\n") args)))

(defun esup-child-send-result-separator ()
"Send the result separator to the parent process."
(process-send-string esup-child-parent-results-process
esup-child-result-separator))

(defun esup-child-send-results (results)
"Send RESULTS to the parent process."
(process-send-string esup-child-parent-results-process
(esup-child-serialize-results results)))
(mapconcat #'prin1-to-string results "\n")))

(defun esup-child-send-eof ()
"Make process see end-of-file in its input."
Expand All @@ -172,14 +123,15 @@ a complete result.")
(setq esup-child-max-depth (or max-depth esup-child-max-depth))
(esup-child-send-log "starting esup-child on '%s' port=%s max-depth=%s"
init-file port esup-child-max-depth)
(advice-add 'require :around 'esup-child-require-advice)
(advice-add 'load :around 'esup-child-load-advice)
(advice-add 'require :around #'esup-child-require-advice)
(advice-add 'load :around #'esup-child-load-advice)
(setq enable-local-variables :safe)
(esup-child-log-invocation-options)
(prog1
(esup-child-profile-file init-file)
(advice-remove 'require 'esup-child-require-advice)
(advice-remove 'load 'esup-child-load-advice)
(require 'package)
(package-initialize)
(prog1 (esup-child-profile-file init-file)
(advice-remove 'require #'esup-child-require-advice)
(advice-remove 'load #'esup-child-load-advice)
(kill-emacs)))

(defun esup-child-chomp (str)
Expand All @@ -189,37 +141,31 @@ a complete result.")
(setq str (replace-match "" t t str)))
str)

(defun esup-child-s-pad-left (len padding s)
"If S is shorter than LEN, pad it with PADDING on the left."
(let ((extra (max 0 (- len (length s)))))
(concat (make-string extra (string-to-char padding))
s)))

(defun esup-child-unindent (str)
"Remove common leading whitespace from each line of STR.
If STR contains only whitespace, return an empty string."
(let* ((lines (split-string str "\\(\r\n\\|[\n\r]\\)"))
(non-whitespace-lines (seq-filter (lambda (s) (< 0 (length (string-trim-left s))))
lines))
(n-to-trim (apply #'min (mapcar (lambda (s) (- (length s) (length (string-trim-left s))))
(or non-whitespace-lines [""]))))
(result (string-join (mapcar (lambda (s) (substring (esup-child-s-pad-left n-to-trim " " s) n-to-trim))
lines)
"\n")))
(if (= 0 (length (esup-child-chomp result))) "" result)))
(defun esup-child-unindent (string)
"Remove common indentation from each line in STRING.
If STR contains only whitespace, return nil."
(with-temp-buffer
(insert string)
(let ((minimal-indent most-positive-fixnum))
(save-excursion
(goto-char (point-min))
(while (not (eobp))
(unless (looking-at-p "^[^[:space:]]*$")
(setq minimal-indent (min (current-indentation)
minimal-indent)))
(forward-line)))
(indent-rigidly (point-min) (point-max) (- minimal-indent))
(if (= minimal-indent most-positive-fixnum)
nil
(buffer-substring (point-min) (point-max))))))

(defmacro with-esup-child-increasing-depth (&rest body)
"Run BODY and with an incremented depth level.
Decrement the depth level after complete."
`(progn
(setq esup-child-current-depth (1+ esup-child-current-depth))
`(let ((esup-child-current-depth (1+ esup-child-current-depth)))
(setq esup-child-last-call-intercept-results '())
(prog1
;; This is cleared after `esup-child-profile-string' completes.
(setq esup-child-last-call-intercept-results
(progn ,@body))
(setq esup-child-current-depth
(1- esup-child-current-depth)))))
(setq esup-child-last-call-intercept-results
(progn ,@body))))

(defun esup-child-require-advice
(old-require-fn feature &optional filename noerror)
Expand Down Expand Up @@ -271,16 +217,13 @@ Only profiles if `esup-child-max-depth' isn't reached."
(defun esup-child-profile-file (file-name)
"Profile FILE-NAME and return the benchmarked expressions."
(esup-child-send-log "profiling file='%s'" file-name)
(let* ((clean-file (esup-child-chomp file-name))
(abs-file-path
(locate-file clean-file load-path
;; Add empty string in case the user has (load
;; "file.el"), otherwise we'll look for file.el.el
(cons "" load-suffixes))))
(let ((abs-file-path
(locate-file file-name load-path
;; Add empty string in case the user has (load
;; "file.el"), otherwise we'll look for file.el.el
(cons "" load-suffixes))))
(if abs-file-path
(progn
(esup-child-send-log "loading %s" abs-file-path)
(esup-child-profile-buffer (find-file-noselect abs-file-path)))
(esup-child-profile-buffer (find-file-noselect abs-file-path))
;; The file doesn't exist, return an empty list of `esup-result'
(esup-child-send-log "found no matching files for %s" abs-file-path)
'())))
Expand All @@ -293,15 +236,14 @@ Only profiles if `esup-child-max-depth' isn't reached."
(defun esup-child-create-location-info-string (&optional buffer)
"Create a string of the location info for BUFFER.
BUFFER defaults to the current buffer."
(unless buffer (setq buffer (current-buffer)))
(let* ((line-number (line-number-at-pos (point)))
(file-name (with-current-buffer buffer (buffer-file-name)))
(location-information
(format "%s:%d" file-name line-number)))
location-information))
(with-current-buffer (or buffer (current-buffer))
(let ((line-number (line-number-at-pos (point)))
(file-name (buffer-file-name)))
(format "%s:%d" file-name line-number))))

(defun esup-child-profile-buffer (buffer)
"Profile BUFFER and return the benchmarked expressions."
(esup-child-send-log "loading %s" (buffer-file-name buffer))
(condition-case-unless-debug error-message
(with-current-buffer buffer
(goto-char (point-min))
Expand All @@ -312,21 +254,21 @@ BUFFER defaults to the current buffer."
;; white-space and comments.
(let ((buffer-read-only t)
(last-start -1)
(end (progn (forward-sexp 1) (point)))
(start (progn (forward-sexp -1) (point)))
(end (save-excursion (forward-sexp 1) (point)))
(start (save-excursion (forward-sexp -1) (point)))
results
(after-init-time nil))
(while (> start last-start)
(setq results
(append results (esup-child-profile-sexp start end)))
(push (esup-child-profile-sexp start end)
results)
(setq last-start start)
(goto-char end)
(esup-child-skip-byte-code-dynamic-docstrings)
(forward-sexp 1)
(setq end (point))
(forward-sexp -1)
(setq start (point)))
results))
(nreverse results)))
(error
(esup-child-send-log "ERROR(profile-buffer) at %s %s"
(esup-child-create-location-info-string buffer)
Expand All @@ -339,29 +281,20 @@ Returns a list of class `esup-result'."
(let* ((sexp-string (esup-child-unindent (buffer-substring start end)))
(line-number (line-number-at-pos start))
(file-name (buffer-file-name))
sexp
esup--profile-results)
(sexp (and sexp-string (car-safe (read-from-string sexp-string)))))
(esup-child-send-log
"profiling sexp at %s: %s"
(esup-child-create-location-info-string)
(buffer-substring-no-properties start (min end (+ 30 start))))

(condition-case-unless-debug error-message
(progn
(setq sexp (if (string-equal sexp-string "")
""
(car-safe (read-from-string sexp-string))))

(cond
((string-equal sexp-string "") '())

(t
(setq esup--profile-results
(esup-child-profile-string sexp-string file-name line-number
start end))
(esup-child-send-results esup--profile-results)
(esup-child-send-result-separator)
esup--profile-results)))
(when sexp-string
(let ((results (esup-child-profile-string
sexp sexp-string
file-name line-number
start end)))
(esup-child-send-results results)
results))
(error
(esup-child-send-log "ERROR(profile-sexp) at %s with sexp %s: error=%s"
(esup-child-create-location-info-string)
Expand All @@ -370,17 +303,13 @@ Returns a list of class `esup-result'."
(esup-child-send-eof)))))

(defun esup-child-profile-string
(sexp-string &optional file-name line-number start-point end-point)
(sexp sexp-string &optional file-name line-number start-point end-point)
"Profile SEXP-STRING.
Returns an `esup-reusult'. FILE-NAME is the file that
SEXP-STRING was `eval'ed in. LINE-NUMBER is the line number of
the string. START-POINT and END-POINT are the points at which
SEXP-STRING appears in FILE-NAME."
(let ((sexp (if (string-equal sexp-string "")
""
(car-safe (read-from-string sexp-string))))
benchmark)
(setq benchmark (benchmark-run (eval sexp)))
Returns a list of `esup-reusult' objects. FILE-NAME is the file
that SEXP-STRING was `eval'ed in. LINE-NUMBER is the line number
of the string. START and END are the points at which SEXP-STRING
appears in FILE-NAME."
(let ((benchmark (benchmark-run (eval sexp lexical-binding))))
(prog1
(if esup-child-last-call-intercept-results
;; We intercepted the last call with advice on load or
Expand All @@ -394,14 +323,13 @@ SEXP-STRING appears in FILE-NAME."

;; Otherwise, use the normal profile results.
(list
(esup-result (when (<= emacs-major-version 25) "esup-result")
:file file-name
:expression-string sexp-string
:start-point start-point :end-point end-point
:line-number line-number
:exec-time (nth 0 benchmark)
:gc-number (nth 1 benchmark)
:gc-time (nth 2 benchmark))))
(make-esup-result :file file-name
:expression-string sexp-string
:start-point start-point :end-point end-point
:line-number line-number
:exec-time (nth 0 benchmark)
:gc-number (nth 1 benchmark)
:gc-time (nth 2 benchmark))))
;; Reset for the next invocation.
(setq esup-child-last-call-intercept-results nil))))

Expand All @@ -423,30 +351,5 @@ SEXP-STRING appears in FILE-NAME."
('string filename)
('cons (eval filename)))))

(defun esup-child-serialize-result (esup-result)
"Serialize an ESUP-RESULT into a `read'able string.
We need this because `prin1-to-string' isn't stable between Emacs 25 and 26."
(concat
"(esup-result (when (<= emacs-major-version 25) \"esup-result\") "
(format ":file %s "
(prin1-to-string (slot-value esup-result 'file)))
(format ":start-point %d " (slot-value esup-result 'start-point))
(format ":line-number %d " (slot-value esup-result 'line-number))
(format ":expression-string %s "
(prin1-to-string (slot-value esup-result 'expression-string)))
(format ":end-point %d " (slot-value esup-result 'end-point))
(format ":exec-time %f " (slot-value esup-result 'exec-time))
(format ":gc-number %d " (slot-value esup-result 'gc-number))
(format ":gc-time %f" (slot-value esup-result 'gc-time))
")"))

(defun esup-child-serialize-results (esup-results)
"Serialize a list of ESUP-RESULTS into a `read'able string."
(format "(list\n %s)"
(mapconcat 'identity
(cl-loop for result in esup-results
collect (esup-child-serialize-result result))
"\n ")))

(provide 'esup-child)
;;; esup-child.el ends here
Loading

0 comments on commit 2837814

Please sign in to comment.