summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--catbird/overlay.scm148
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))))