bug#25122: 24.5; function describe-variable hangs on large variables

[npostavs@users.sourceforge.net]

[-- Attachment #1: Type: text/plain, Size: 2534 bytes --]

Thierry Volpiatto <thierry.volpiatto@gmail.com> writes:

> npostavs@users.sourceforge.net writes:
>
>> I've been attempting an alternate approach which prettyprints the object
>> while scanning it instead of the current way of printing and then
>> reindenting.  Without optimizing, it's about 3 times as fast as the
>> current pp (it's the pp-prin1 in the benchmarks below), though more than
>> 3 times slower than your mapc pp trick.  On the other hand, it also
>> doesn't yet handle function-specific indentation or any compound
>> structure apart from lists, so I'm not sure if it will end up being much
>> faster.
>>
>> (benchmark 1 '(with-temp-buffer (pp-prin1 long-list (current-buffer)) nil)) "Elapsed time: 3.391232s (0.565806s in 11 GCs)"
>> (benchmark 1 '(progn (pp-to-string long-list) nil))                         "Elapsed time: 9.988515s (0.148034s in 3 GCs)"
>> (benchmark 1 '(progn (with-output-to-string (mapc 'pp long-list)) nil))     "Elapsed time: 0.983493s (0.144424s in 3 GCs)"
>> (benchmark 1 '(progn (cl-prin1-to-string long-list) nil))                   "Elapsed time: 0.511617s (0.152483s in 3 GCs)"
>> (benchmark 1 '(progn (prin1-to-string long-list) nil))                      "Elapsed time: 0.029320s"
>
> Interesting, thanks to work on this.

With a couple of minor optimizations it's down to about 1.8s.  The first
is to reuse the tempbuffer instead of letting cl-prin1-to-string make a
new one each time.  Second is to add

    (eval-when-compile
      (cl-proclaim '(optimize (speed 3) (safety 0))))

This also stops these warnings (I guess they're caused by the "safety" code?):

../../emacs-master/lisp/emacs-lisp/pp.el:159:19:Warning: value returned from
    (aref state 6) is unused
../../emacs-master/lisp/emacs-lisp/pp.el:204:24:Warning: value returned from
    (aref state 10) is unused

New times:

(benchmark 1 '(with-temp-buffer (pp-prin1 long-list (current-buffer)) nil)) "Elapsed time: 1.800146s (0.231706s in 6 GCs)"
(benchmark 1 '(progn (pp-to-string long-list) nil))                         "Elapsed time: 9.950225s (0.154100s in 4 GCs)"
(benchmark 1 '(progn (with-output-to-string (mapc 'pp long-list)) nil))     "Elapsed time: 0.980923s (0.149787s in 4 GCs)"

I foolishly neglected to write down what exactly long-list was before,
starting from emacs -Q this seems to approximate it though:

(progn (require 'pp)
       (require 'dabbrev)
       (require 'edebug)
       (require 'cc-mode)
       (require 'vc)
       (setq long-list load-history)
       (length long-list)) ;=> 142


[-- Attachment #2: patch --]
[-- Type: text/plain, Size: 7289 bytes --]

From e4b1a2ef3b4b11466e81d639a09ff671318e0968 Mon Sep 17 00:00:00 2001
From: Noam Postavsky <npostavs@gmail.com>
Date: Sat, 11 Mar 2017 00:09:36 -0500
Subject: [PATCH v2] New pretty printer (Bug#25122)

* lisp/emacs-lisp/pp.el (pp-state): New struct.
(pp--scan): New function, measures length of sublists (actually
"logical blocks" to allow for more customizable grouping than just by
lists).  Calls pp--print when scanned tokens are too wide to fit on a
single line.
(pp--print): New function, prints tokens horizontally or vertically
depending on whether the sublist can fit within the line.
(pp-prin1): New function, entry point for pp--scan and pp-print.
(pp-print-object): New generic function.
(pp-print-object) <cons , _>: New method, prettyprinter for lists.
---
 lisp/emacs-lisp/pp.el | 156 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 156 insertions(+)

diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el
index 7ef46a48bd..8c2ed24ffd 100644
--- a/lisp/emacs-lisp/pp.el
+++ b/lisp/emacs-lisp/pp.el
@@ -24,6 +24,9 @@
 
 ;;; Code:
 
+(eval-when-compile (require 'cl-lib))
+(require 'ring)
+
 (defvar font-lock-verbose)
 
 (defgroup pp nil
@@ -121,6 +124,159 @@ pp-display-expression
 	(setq buffer-read-only nil)
 	(set (make-local-variable 'font-lock-verbose) nil)))))
 
+(eval-when-compile
+  ;; FIXME: should we try to restore original settings? (how?)
+  (cl-proclaim '(optimize (speed 3) (safety 0))))
+
+(cl-defstruct (pp-state (:constructor
+                         make-pp-state
+                         (stream
+                          tempbuffer
+                          right-margin
+                          &aux
+                          (left-margin 0)
+                          (indent '(0))
+                          (scan-depth 0)
+                          (print-depth 0)
+                          (print-width 0)
+                          (scan-width 0)
+                          (block-mode (list nil))
+                          (fifo (make-ring 30)))))
+  stream
+  tempbuffer
+  right-margin ; how far we may go.
+  left-margin  ; how far printer has gone
+  print-width ; total width of tokens printed so far.
+  indent ; left-margin, stack per depth.
+  scan-width ; total width of tokens scanned so far.
+  scan-depth
+  print-depth
+  block-widths
+  block-mode ; `:vertical', `:horizontal', nil (undecided); stack per depth.
+  fifo
+  )
+
+(defun pp--print (state)
+  (cl-symbol-macrolet ((stream (pp-state-stream state))
+                       (depth (pp-state-print-depth state))
+                       (scan-depth (pp-state-scan-depth state))
+                       (fifo (pp-state-fifo state))
+                       (left-margin (pp-state-left-margin state))
+                       (width (pp-state-print-width state))
+                       (indent (pp-state-indent state))
+                       (right-margin (pp-state-right-margin state))
+                       (block-mode (pp-state-block-mode state)))
+    (catch 'rescan
+      (while (not (ring-empty-p fifo))
+        (pcase (ring-remove fifo)
+          ((and `(,len . :open-block) token)
+           (if (<= len 0)
+               ;; Not ready to print this yet!
+               (progn (ring-insert-at-beginning fifo token)
+                      (throw 'rescan nil))
+             (cl-incf depth)
+             (push left-margin indent)
+             (push (if (> (+ left-margin len) right-margin)
+                       :vertical :horizontal)
+                   block-mode)))
+          (:close-block (cl-decf depth) (pop indent) (pop block-mode))
+          (:blank
+           (pcase (car block-mode)
+            (:vertical
+             (terpri stream)
+             (princ (make-string (car indent) ?\s) stream)
+             (setf left-margin (car indent)))
+            ((or :horizontal 'nil)
+             (write-char ?\s stream)
+             (cl-incf left-margin))
+            (_ (error "oops")))
+           (cl-incf width))
+          (:eof nil)
+          ((and (pred characterp) char)
+           (write-char char stream)
+           (cl-incf left-margin (char-width char))
+           (cl-incf width (char-width char)))
+          (string
+           (princ string stream)
+           (cl-incf left-margin (string-width string))
+           (cl-incf width (string-width string))))))))
+
+(defun pp--scan (token state)
+  (cl-symbol-macrolet ((stream (pp-state-stream state))
+                       (depth (pp-state-scan-depth state))
+                       (print-depth (pp-state-print-depth state))
+                       (fifo (pp-state-fifo state))
+                       (width (pp-state-scan-width state))
+                       (right-margin (pp-state-right-margin state))
+                       (block-widths (pp-state-block-widths state)))
+    (cl-flet ((scanlen (len) (cl-incf width len)))
+      (cl-assert (> (ring-size fifo) (ring-length fifo)))
+      (ring-insert fifo token)
+      (pcase token
+        (:open-block
+         (cl-incf depth)
+         (let ((block-token (cons (- width) (ring-remove fifo 0))))
+           (push block-token block-widths)
+           (ring-insert fifo block-token)))
+        (:close-block
+         (cl-incf (caar block-widths) width)
+         (when (> (caar block-widths) right-margin)
+           (pp--print state))
+         (cl-decf depth)
+         (pop block-widths))
+        (:blank (scanlen 1))
+        (:eof (pp--print state))
+        ((pred characterp) (scanlen (char-width token)))
+        (_ (scanlen (string-width token)))))
+    (when block-widths
+      (when (> (+ (caar block-widths) width) right-margin)
+        (dolist (block-width block-widths)
+          (setf (car block-width) (+ right-margin 1))))
+      (when (> (caar block-widths) right-margin)
+        (pp--print state)))))
+
+(defvar cl-print-readably) ; cl-print.el
+
+(defun pp-prin1 (object &optional stream right-margin)
+  (unless right-margin
+    (setq right-margin fill-column))
+  (with-temp-buffer
+    (let ((cl-print-readably nil)
+          (state (make-pp-state (or stream standard-output) (current-buffer)
+                                right-margin)))
+      (pp--scan :open-block state)
+      (prog1 (pp-print-object object state)
+        (pp--scan :close-block state)
+        (pp--scan :eof state)))))
+
+
+(cl-defgeneric pp-print-object (object state)
+  ;; Fallback to standard `cl-print-object'.
+  (pp--scan (with-current-buffer (pp-state-tempbuffer state)
+              (cl-prin1 object (current-buffer))
+              (prog1 (buffer-string)
+                (erase-buffer)))
+            state)
+  object)
+
+(cl-defmethod pp-print-object ((list cons) state)
+  (pcase list
+    (`(,head . ,tail)
+     (pp--scan "(" state)
+     (pp--scan :open-block state)
+     (pp-print-object head state)
+     (while (consp tail)
+       (pp--scan :blank state)
+       (pp-print-object (pop tail) state))
+     (when tail
+       (pp--scan :blank state)
+       (pp--scan ?\. state)
+       (pp--scan :blank state)
+       (pp-print-object tail state))
+     (pp--scan :close-block state)
+     (pp--scan ")" state)))
+  list)
+
 ;;;###autoload
 (defun pp-eval-expression (expression)
   "Evaluate EXPRESSION and pretty-print its value.
-- 
2.11.1