From add76312e55208389fa4487d555521a67f051f05 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Fran=C3=A7ois-Ren=C3=A9=20Rideau?= <fare@tunes.org>
Date: Fri, 3 Nov 2023 21:59:09 -0400
Subject: [PATCH] std/debug/DBG print-debugging utility (#1040)

Import DBG from gerbil-utils' clan/debug.
Test and document it.
---
 doc/reference/std/debug.md | 93 +++++++++++++++++++++++++++++---------
 src/std/build-spec.ss      |  1 +
 src/std/debug/DBG.ss       | 55 ++++++++++++++++++++++
 3 files changed, 127 insertions(+), 22 deletions(-)
 create mode 100644 src/std/debug/DBG.ss

diff --git a/doc/reference/std/debug.md b/doc/reference/std/debug.md
index af98a8f62e..eeb6d0aa19 100644
--- a/doc/reference/std/debug.md
+++ b/doc/reference/std/debug.md
@@ -8,14 +8,14 @@ These are miscallenous libraries useful for debugging running programs.
 :::
 
 ### memory-usage
-```
+```scheme
 (memory-usage)
 ```
 
 Aggregates useful memory statistics.
 
 Example:
-```
+```scheme
 > (memory-usage)
 ((gc-heap-size . 31101000)
  (gc-alloc . 35786424)
@@ -26,7 +26,7 @@ Example:
 ```
 
 ### heap-type-stats
-```
+```scheme
 (heap-type-stats) -> (values live-objects type-table)
 ```
 
@@ -34,14 +34,14 @@ Returns two values, the number of live objects and a table containing
 a count for each type of live object.
 
 ### dump-heap-stats!
-```
+```scheme
 (dump-heap-stats! (port (current-error-port)))
 ```
 
 Dumps the current live heap statistics to `port`.
 
 Example:
-```
+```scheme
 > (dump-heap-stats!)
 === memory usage ===
 gc-heap-size: 31118680
@@ -140,7 +140,7 @@ gx#root-context::t 1
 ```
 
 ### walk-heap!
-```
+```scheme
 (walk-heap! walk: (walk #f) root: (root #f)) -> hash-table
 ```
 
@@ -150,7 +150,7 @@ and optionally using `walk` as the function for walking container objects.
 Returns a table of all visited objects.
 
 ### count-still
-```
+```scheme
 (count-still) -> (values still refcounted)
 ```
 
@@ -158,14 +158,14 @@ Returns two values: the number of still objects and how many of them are
 reference counted in the heap.
 
 ### still-objects
-```
+```scheme
 (still-objects ...)
 ```
 
 Counts the still objects in the heap.
 
 ### still-objects/refcount
-```
+```scheme
 (still-objects/refcount ...)
 ```
 
@@ -178,28 +178,28 @@ Counts the reference counted objects in the heap.
 :::
 
 ### heap-summary
-```
+```scheme
 (heap-summary)
 ```
 
 Returns a differentiable heap summary.
 
 ### heap-summary-delta
-```
+```scheme
 (heap-summary-delta old new)
 ```
 
 Differentiates two heap summaries.
 
 ### dump-heap-summary!
-```
+```scheme
 (dump-heap-summary! summary (port (current-error-port)))
 ```
 
 Dumps a heap summary to `port`.
 
 Example:
-```
+```scheme
 > (dump-heap-summary! (heap-summary))
 ==================================
 timestamp: 1696260626.4030066
@@ -303,7 +303,7 @@ gx#root-context::t: 1
 ```
 
 ### watch-heap!
-```
+```scheme
 (watch-heap! (port (current-error-port))
               delay: (initial-delay 60)
               period: (period (* 60 15))
@@ -320,7 +320,7 @@ after `initial-delay`.
 :::
 
 ### dump-all-threads!
-```
+```scheme
 (dump-all-threads! (port (current-error-port))
                    (filter true))
 ```
@@ -329,7 +329,7 @@ Dumps the state of all threads that satisfy the `filter` procedure.
 
 
 ### dump-all-threads/queue!
-```
+```scheme
 (dump-all-threads/queue! (port (current-error-port)))
 ```
 
@@ -337,7 +337,7 @@ Dumps all threads with a non empty message queue (mailbox).
 
 
 ### dump-thread-group!
-```
+```scheme
 (dump-thread-group! (tg (current-thread-group))
                     (port (current-error-port))
                     (filter true))
@@ -348,7 +348,7 @@ the filter `filter`.
 
 
 ### dump-thread-group!*
-```
+```scheme
 (dump-thread-group!* (tg (current-thread-group))
                           (port (current-error-port))
                           (filter true))
@@ -357,7 +357,7 @@ the filter `filter`.
 Like `dump-thread-group!`, but also recursively dumps all child thread groups.
 
 ### dump-thread!
-```
+```scheme
 (dump-thread! thread (port (current-error-port)))
 ```
 
@@ -365,22 +365,71 @@ Dumps the state of a thread, including the size of its message queue
 and stack trace.
 
 ### dump-thread-stack-trace!
-```
+```scheme
 (dump-thread-stack-trace! thread (port (current-error-port)))
 ```
 
 Dumps a thread's stack trace.
 
 ### thread-queue-length
-```
+```scheme
 (thread-queue-length thread)
 ```
 
 Returns the current length of a thread's message queue.
 
 ### thread-queue-empty?
-```
+```scheme
 (thread-queue-empty? thread)
 ```
 
 Returns true if the `thread`'s message queue is empty.
+
+
+## Print-debugging utilities
+::: tip To use bindings from this module
+(import :std/debug/DBG)
+:::
+
+### DBG
+```scheme
+(DBG tag expr1 ... exprN) => values-of-the-last-expression
+```
+
+If the `tag` doesn't evaluate to `#f`, print the tag, then on separate lines
+the source of each expression `expr1` to `exprN` (as by `write`)
+followed by its single or multiple return values (as by `prn`).
+Finally, return the values of the last expression `exprN`.
+
+You can easily wrap an expression in a `DBG` form so as to print its value,
+together with the values of other relevant expressions,
+when trying to figure out where and how evaluation is failing your expectations
+in some part of your code.
+
+Example:
+```scheme
+> (define-values (x y z) (values 1 2 3))
+> (* 10 (DBG foo: x (values [(+ x y) z] #t) (+ x y z)))
+foo
+  x => 1
+  (values (@list (+ x y) z) #t) => [3 3] #t
+  (+ x y z) => 6
+60
+```
+In the above example the tag `foo` and the indented lines are printed by `DBG`,
+whereas the 60 is the final value returned and printed by the REPL.
+Notice how the `DBG` form returns the value of the last expression, 6,
+that subsequently got multiplied by 10 as per regular evaluation,
+to result in the final 60.
+
+### DBG-helper
+```
+(DBG-helper tag dbg-exprs dbg-thunks expr thunk) => values of the thunk
+```
+
+This is the function that `DBG` expands into, taking as parameters
+the `tag`, a list `dbg-exprs` of all-but-the-last expressions (quoted),
+a list `dbg-thunks` of thunks for all-but-the-last expressions,
+then the last expression `expr` (quoted) and the `thunk` for it.
+Your code can conceivably expand to calls to `DBG-helper` with e.g.
+suitable wrappings to tweak what expressions are printed.
diff --git a/src/std/build-spec.ss b/src/std/build-spec.ss
index 4d64a47db9..9db1a25e7d 100644
--- a/src/std/build-spec.ss
+++ b/src/std/build-spec.ss
@@ -74,6 +74,7 @@
     "io/socket/socket"
     "io/socket/api"
     ;; debugging
+    "debug/DBG"
     (gxc: "debug/heap" ,@(include-gambit-sharp))
     "debug/memleak"
     (gxc: "debug/threads" ,@(include-gambit-sharp))
diff --git a/src/std/debug/DBG.ss b/src/std/debug/DBG.ss
new file mode 100644
index 0000000000..c8b257f945
--- /dev/null
+++ b/src/std/debug/DBG.ss
@@ -0,0 +1,55 @@
+;;; -*- Gerbil -*-
+;;; © fare
+;;; DBG utility
+
+(export #t)
+
+(import
+  (only-in :std/format fprintf))
+
+;; DBG macro for easier print-debugging
+;; as ported from Common Lisp's ASDF (in asdf/uiop/contrib/debug.lisp).
+;;
+;; Usage: (DBG tag forms ...)
+;;
+;; tag is typically a constant string or keyword to identify who is printing,
+;; but can be an arbitrary expression returning a tag to be display'ed first;
+;; if the expression returns #f, nothing is printed.
+;;
+;; forms are expressions, which when the tag was not #f are evaluated in order,
+;; with their source code then their return values being write'n each time.
+;; The last expression is *always* evaluated and its multiple values are returned,
+;; but its source and return values are only printed if tag was not #f;
+;; previous expressions are not evaluated at all if tag was #f.
+;; The macro expansion has relatively low overhead in space or time.
+;;
+(defrules DBG ()
+  ((_ tag-expr)
+   (DBG-helper tag-expr '() '() #f #f))
+  ((_ tag-expr dbg-expr ... expr)
+   (let ((tagval tag-expr)
+         (thunk (lambda () expr)))
+     (if tagval
+       (DBG-helper tagval '(dbg-expr ...) (list (lambda () dbg-expr) ...)
+                   'expr thunk)
+       (thunk)))))
+
+;; NB: fprintf uses the current-error-port and calls force-output
+(def (DBG-helper tag dbg-exprs dbg-thunks expr thunk)
+  (letrec
+      ((f (lambda (fmt . args)
+            (force-output (current-output-port)) ;; avoid out-of-order issues due to stdout buffering
+            (apply fprintf (current-error-port) fmt args)
+            (force-output (current-error-port))))
+       (v (lambda (l)
+            (for-each (lambda (x) (f " ~r" x)) l)
+            (f "~%")))
+       (x (lambda (expr thunk)
+            (f "  ~s =>" expr)
+            (call-with-values thunk (lambda x (v x) (apply values x))))))
+    (if tag
+      (begin
+        (unless (void? tag) (f "~a~%" tag))
+        (for-each x dbg-exprs dbg-thunks)
+        (if thunk (x expr thunk) (void)))
+      (if thunk (thunk) (void)))))