Add GC stats display to overlay.

1 files changed, 146 insertions, 2 deletions

diff --git a/catbird/overlay.scm b/catbird/overlay.scm
index 420b146..8d1306c 100644
--- a/catbird/overlay.scm
+++ b/catbird/overlay.scm
@@ -27,6 +27,7 @@
   #:use-module (catbird region)
   #:use-module (catbird repl)
   #:use-module (catbird scene)
+  #:use-module (catbird ui)
   #:use-module (chickadee graphics color)
   #:use-module (chickadee graphics path)
   #:use-module (chickadee graphics text)
@@ -101,6 +102,13 @@
   "- Resume game."
   (unfreeze-all-regions))
 
+
+;;;
+;;; FPS Display
+;;;
+
+(define %metrics-bg-color (make-color 1.0 0 0 0.8))
+
 (define-class <fps-display> (<node-2d>))
 
 (define-method (on-boot (fps-display <fps-display>))
@@ -113,7 +121,7 @@
                (make <canvas>
                  #:name 'background
                  #:painter
-                 (with-style ((fill-color (make-color 0 0 0 0.5)))
+                 (with-style ((fill-color %metrics-bg-color))
                    (fill
                     (rectangle (vec2 0.0 0.0)
                                box-width
@@ -157,4 +165,140 @@
 (define-minibuffer-command repl
   (let ((s (scene-for-region 'overlay)))
     (when s
-      (push-major-mode s (make <repl-mode>)))))
+      (open-repl s))))
+
+
+;;;
+;;; GC Display
+;;;
+
+(define-class <gc-display> (<node-2d>))
+
+(define-method (initialize (gc-display <gc-display>) initargs)
+  (next-method)
+  (let* ((font (default-font))
+         (padding 4.0))
+    (attach-to gc-display
+               (make <canvas>
+                 #:name 'background
+                 #:painter
+                 (with-style ((fill-color %metrics-bg-color))
+                   (fill
+                    (rectangle (vec2 0.0 0.0) 10.0 10.0))))
+               (make <margin-container>
+                 #:name 'table
+                 #:margin padding
+                 #:children
+                 (list (make <horizontal-container>
+                         #:name 'columns
+                         #:children
+                         (list (make <vertical-container>
+                                 #:name 'names
+                                 #:children
+                                 (list (make <label>
+                                         #:text "GC time taken")
+                                       (make <label>
+                                         #:text "Heap size")
+                                       (make <label>
+                                         #:text "Heap free size")
+                                       (make <label>
+                                         #:text "Heap total allocated")
+                                       (make <label>
+                                         #:text "Heap allocated since GC")
+                                       (make <label>
+                                         #:text "Protected objects")
+                                       (make <label>
+                                         #:text "GC times")))
+                               (make <margin-container>
+                                 #:margin padding)
+                               (make <vertical-container>
+                                 #:name 'values
+                                 #:children
+                                 (list (make <label>
+                                         #:name 'gc-time-taken)
+                                       (make <label>
+                                         #:name 'heap-size)
+                                       (make <label>
+                                         #:name 'heap-free-size)
+                                       (make <label>
+                                         #:name 'heap-total-allocated)
+                                       (make <label>
+                                         #:name 'heap-allocated-since-gc)
+                                       (make <label>
+                                         #:name 'protected-objects)
+                                       (make <label>
+                                         #:name 'gc-times))))))))
+    (run-script gc-display
+      (forever
+       (refresh-gc-stats gc-display)
+       (sleep 1.0)))))
+
+(define KiB (expt 2 10))
+(define MiB (expt 2 20))
+(define GiB (expt 2 30))
+
+(define (bytes->human-readable-string bytes)
+  (cond
+   ((< bytes KiB)
+    (format #f "~d B" bytes))
+   ((< bytes MiB)
+    (format #f "~1,2f KiB" (/ bytes KiB)))
+   ((< bytes GiB)
+    (format #f "~1,2f MiB" (/ bytes MiB)))
+   (else
+    (format #f "~1,2f GiB" (/ bytes GiB)))))
+
+(define second internal-time-units-per-second)
+(define minute (* 60 second))
+(define hour (* 60 minute))
+(define day (* 24 hour))
+
+(define (time->human-readable-string time)
+  (cond
+   ((< time minute)
+    (format #f "~1,2f seconds" (round (/ time second))))
+   ((< time hour)
+    (format #f "~1,2f minutes" (round (/ time minute))))
+   ((< time day)
+    (format #f "~1,2f hours" (round (/ time hour))))
+   (else
+    (format #f "~1,2f days" (round (/ time day))))))
+
+(define-method (refresh-gc-stats (gc-display <gc-display>))
+  (define (stat-label name)
+    (let ((container (& gc-display table columns values)))
+      (child-ref container name)))
+  (let ((stats (gc-stats)))
+    (set! (text (stat-label 'gc-time-taken))
+          (time->human-readable-string (assq-ref stats 'gc-time-taken)))
+    (set! (text (stat-label 'heap-size))
+          (bytes->human-readable-string (assq-ref stats 'heap-size)))
+    (set! (text (stat-label 'heap-free-size))
+          (bytes->human-readable-string (assq-ref stats 'heap-free-size)))
+    (set! (text (stat-label 'heap-total-allocated))
+          (bytes->human-readable-string (assq-ref stats 'heap-total-allocated)))
+    (set! (text (stat-label 'heap-allocated-since-gc))
+          (bytes->human-readable-string (assq-ref stats 'heap-allocated-since-gc)))
+    (set! (text (stat-label 'protected-objects))
+          (number->string (assq-ref stats 'protected-objects)))
+    (set! (text (stat-label 'gc-times))
+          (number->string (assq-ref stats 'gc-times))))
+  (resize (& gc-display background)
+          (width (& gc-display table))
+          (height (& gc-display table))))
+
+(define-minibuffer-command show-gc
+  (let* ((r (find-region-by-name 'overlay))
+         (s (and r (scene r))))
+    (when (and s (not (& s gc-display)))
+      (let ((gc-display (make <gc-display>
+                          #:name 'gc-display
+                          #:rank 99)))
+        (attach-to s gc-display)
+        (set! (position-y gc-display)
+              (- (area-height r) 124.0))))))
+
+(define-minibuffer-command hide-gc
+  (let* ((s (scene-for-region 'overlay))
+         (f (and s (& s gc-display))))
+    (when f (detach f))))