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

From: [email-masked]
Date: Sat, 11 Mar 2017 00:40:03 -0500

Thierry Volpiatto <[email-masked]> writes:
>
> I don't think it would be as fast as printing one by one each elements.
> What is slow is printing the whole object.
> See how bookmark file is saved, it was taking more than one minute for
> my bookmarks before printing one by one, now it is instant or nearly.

Actually, it's the indent-sexp on the whole object that takes time.
Possibly we could sacrifice some indentation correctness if the printed
representation is big.

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"

>From 66f6dda0507fa4699ba929379cd1c58ef8b540f5 Mon Sep 17 00:00:00 2001
From: Noam Postavsky <[email-masked]>
Date: Sat, 11 Mar 2017 00:09:36 -0500
Subject: [PATCH v1] Initial draft of 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.
Wraps stream so that cl-print will dispatch to prettyprinting methods.
(cl-print-object) <_ (head :pprint)>: New method, wraps
cl-prin1-to-string for prettyprinting.
(cl-print-object) <cons (head :pprint)>: New mthod, prettyprinter for
lists.
---
 lisp/emacs-lisp/pp.el | 143 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 143 insertions(+)

diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el
index 7ef46a48bd..3809325c4b 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,146 @@ pp-display-expression
 	(setq buffer-read-only nil)
 	(set (make-local-variable 'font-lock-verbose) nil)))))
 
+
+(cl-defstruct (pp-state (:constructor
+                         make-pp-state
+                         (stream
+                          &aux
+                          (right-margin fill-column)
+                          (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
+  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)
+  (let ((cl-print-readably nil)
+        (stream (make-pp-state (or stream standard-output))))
+    (pp--scan :open-block stream)
+    (prog1 (cl-prin1 object (cons :pprint stream))
+      (pp--scan :close-block stream)
+      (pp--scan :eof stream))))
+
+;; fallback to standard `cl-print-object'.
+(cl-defmethod cl-print-object (object (stream (head :pprint)))
+  (pp--scan (cl-prin1-to-string object) (cdr stream))
+  object)
+
+(cl-defmethod cl-print-object ((list cons) (stream (head :pprint)))
+  (let ((state (cdr stream)))
+    (pcase list
+      (`(,head . ,tail)
+       (pp--scan "(" state)
+       (pp--scan :open-block state)
+       (cl-print-object head stream)
+       (while (consp tail)
+         (pp--scan :blank state)
+         (cl-print-object (pop tail) stream))
+       (when tail
+         (pp--scan :blank state)
+         (pp--scan ?\. state)
+         (pp--scan :blank state)
+         (cl-print-object tail stream))
+       (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