diff options
| -rw-r--r-- | catbird/overlay.scm | 148 |
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)))) |