std/os/sysmon: cross-platform CPU/MEM/GPU sampler
ober
4db82bb3f58c9f84f558681f320a1eb5abdd47dd
new file mode 100644 --- /dev/null +++ b/lib/std/os/sysmon.sls @@ -0,0 +1,410 @@ +#!chezscheme +;;; (std os sysmon) — Cross-platform CPU/memory/GPU utilization sampler. +;;; +;;; Stateful: the first sysmon-update! seeds counters; subsequent calls +;;; produce CPU% over the elapsed interval. Memory and GPU are point-in-time. +;;; +;;; Linux — /proc/stat, /proc/meminfo; sysfs/nvidia-smi for GPU +;;; macOS — mach host_statistics + sysctlbyname; ioreg for GPU +;;; FreeBSD — sysctlbyname for CPU/memory; GPU returns #f +;;; +;;; Usage: +;;; (define mon (make-sysmon)) +;;; (sysmon-update! mon) +;;; ;; ...later... +;;; (sysmon-update! mon) +;;; (sysmon-cpu-percent mon) ; -> 0..100 inexact +;;; (sysmon-mem-percent mon) ; -> 0..100 inexact +;;; (sysmon-gpu-percent mon) ; -> 0..100 inexact, or #f if unavailable + +(library (std os sysmon) + (export + make-sysmon sysmon? + sysmon-update! + sysmon-cpu-percent + sysmon-mem-used sysmon-mem-total + sysmon-mem-percent + sysmon-gpu-percent) + + (import (chezscheme) + (std os platform)) + + ;; Load libc at library-load time so subsequent foreign-procedure forms + ;; can resolve symbols. file-info.sls uses the same pattern. + (define _libc-loaded + (guard (e [#t #f]) (platform-load-libc))) + + (define-record-type sysmon + (fields (mutable prev-idle) + (mutable prev-total) + (mutable cpu-percent) + (mutable mem-used) + (mutable mem-total) + (mutable gpu-percent) + (mutable gpu-method) ;; 'unknown | 'amd-sysfs | 'nvidia-smi | 'ioreg | #f + (mutable gpu-skip) ;; throttle counter for expensive GPU sampling + (mutable libc-loaded?)) + (protocol + (lambda (new) + (lambda () + (new 0 0 0.0 0 0 #f 'unknown 0 #f))))) + + ;; ===== Public API ===== + + (define (sysmon-update! mon) + (ensure-libc! mon) + (cond + [(platform-linux?) + (linux-update-cpu! mon) + (linux-update-mem! mon) + (linux-update-gpu! mon)] + [(platform-macos?) + (mac-init!) + (mac-update-cpu! mon) + (mac-update-mem! mon) + (mac-update-gpu! mon)] + [(platform-bsd?) + (bsd-init!) + (bsd-update-cpu! mon) + (bsd-update-mem! mon) + (sysmon-gpu-percent-set! mon #f)] + [else + (sysmon-cpu-percent-set! mon 0.0) + (sysmon-mem-used-set! mon 0) + (sysmon-mem-total-set! mon 0) + (sysmon-gpu-percent-set! mon #f)])) + + (define (sysmon-mem-percent mon) + (let ([t (sysmon-mem-total mon)]) + (if (> t 0) + (* 100.0 (/ (sysmon-mem-used mon) t)) + 0.0))) + + ;; ===== Helpers ===== + + (define (ensure-libc! mon) + (unless (sysmon-libc-loaded? mon) + (guard (e [#t (void)]) (platform-load-libc)) + (sysmon-libc-loaded?-set! mon #t))) + + (define (string-has-prefix? prefix s) + (and (>= (string-length s) (string-length prefix)) + (string=? prefix (substring s 0 (string-length prefix))))) + + (define (split-whitespace s) + (let loop ([i 0] [start 0] [out '()]) + (cond + [(= i (string-length s)) + (reverse (if (> i start) (cons (substring s start i) out) out))] + [(char-whitespace? (string-ref s i)) + (loop (+ i 1) (+ i 1) + (if (> i start) (cons (substring s start i) out) out))] + [else (loop (+ i 1) start out)]))) + + (define (string-split-lines s) + (let loop ([i 0] [start 0] [out '()]) + (cond + [(= i (string-length s)) + (reverse (if (> i start) (cons (substring s start i) out) out))] + [(char=? #\newline (string-ref s i)) + (loop (+ i 1) (+ i 1) (cons (substring s start i) out))] + [else (loop (+ i 1) start out)]))) + + (define (string-trim s) + (let* ([n (string-length s)] + [l (let loop ([i 0]) + (if (and (< i n) (char-whitespace? (string-ref s i))) + (loop (+ i 1)) i))] + [r (let loop ([j n]) + (if (and (> j l) (char-whitespace? (string-ref s (- j 1)))) + (loop (- j 1)) j))]) + (substring s l r))) + + (define (parse-int s) + (or (guard (e [#t #f]) (string->number s)) 0)) + + (define (read-text-file path) + (call-with-input-file path get-string-all)) + + (define (list-nth lst n) + (cond [(null? lst) #f] + [(= n 0) (car lst)] + [else (list-nth (cdr lst) (- n 1))])) + + (define (compute-cpu-pct! mon idle total) + (let* ([prev-i (sysmon-prev-idle mon)] + [prev-t (sysmon-prev-total mon)] + [di (- idle prev-i)] + [dt (- total prev-t)]) + (sysmon-prev-idle-set! mon idle) + (sysmon-prev-total-set! mon total) + (cond + [(= prev-t 0) + (sysmon-cpu-percent-set! mon 0.0)] + [(<= dt 0) + (void)] ;; no progress — keep previous + [else + (let ([pct (* 100.0 (- 1.0 (/ (exact->inexact di) (exact->inexact dt))))]) + (sysmon-cpu-percent-set! mon (max 0.0 (min 100.0 pct))))]))) + + ;; Sysctl wrapper used by both macOS and BSD. + (define c-sysctlbyname + (foreign-procedure "sysctlbyname" + (string u8* u8* void* size_t) int)) + + (define (sysctl-read name nbytes) + ;; Returns a fresh bytevector on success, or #f. + (guard (e [#t #f]) + (let* ([buf (make-bytevector nbytes 0)] + [len (make-bytevector 8 0)]) + (bytevector-u64-native-set! len 0 nbytes) + (let ([rc (c-sysctlbyname name buf len 0 0)]) + (and (= rc 0) buf))))) + + (define (sysctl-u64 name) + (let ([bv (sysctl-read name 8)]) + (and bv (bytevector-u64-native-ref bv 0)))) + + (define (sysctl-u32 name) + (let ([bv (sysctl-read name 4)]) + (and bv (bytevector-u32-native-ref bv 0)))) + + ;; ===== Linux ===== + + (define (linux-update-cpu! mon) + (guard (e [#t (void)]) + (let* ([line (call-with-input-file "/proc/stat" get-line)] + [parts (split-whitespace line)]) + (when (and (pair? parts) (string=? (car parts) "cpu")) + (let* ([nums (map parse-int (cdr parts))] + [user (or (list-nth nums 0) 0)] + [nice (or (list-nth nums 1) 0)] + [sys (or (list-nth nums 2) 0)] + [idle (or (list-nth nums 3) 0)] + [io (or (list-nth nums 4) 0)] + [irq (or (list-nth nums 5) 0)] + [sirq (or (list-nth nums 6) 0)] + [steal (or (list-nth nums 7) 0)]) + (compute-cpu-pct! mon + (+ idle io) + (+ user nice sys idle io irq sirq steal))))))) + + (define (linux-update-mem! mon) + (guard (e [#t (void)]) + (let* ([text (read-text-file "/proc/meminfo")] + [lines (string-split-lines text)] + [total (find-meminfo-kb lines "MemTotal:")] + [avail (find-meminfo-kb lines "MemAvailable:")] + [free (find-meminfo-kb lines "MemFree:")]) + (when total + (sysmon-mem-total-set! mon (* total 1024)) + (let ([f (or avail free 0)]) + (sysmon-mem-used-set! mon (* (max 0 (- total f)) 1024))))))) + + (define (find-meminfo-kb lines key) + (let loop ([ls lines]) + (cond + [(null? ls) #f] + [(string-has-prefix? key (car ls)) + (let ([parts (split-whitespace (car ls))]) + (and (>= (length parts) 2) (parse-int (cadr parts))))] + [else (loop (cdr ls))]))) + + (define (linux-update-gpu! mon) + (case (sysmon-gpu-method mon) + [(unknown) + (cond + [(file-exists? "/sys/class/drm/card0/device/gpu_busy_percent") + (sysmon-gpu-method-set! mon 'amd-sysfs) + (linux-update-gpu! mon)] + [(linux-have-cmd? "nvidia-smi") + (sysmon-gpu-method-set! mon 'nvidia-smi) + (linux-update-gpu! mon)] + [else + (sysmon-gpu-method-set! mon #f) + (sysmon-gpu-percent-set! mon #f)])] + [(amd-sysfs) + (guard (e [#t (sysmon-gpu-percent-set! mon #f)]) + (let ([s (read-text-file "/sys/class/drm/card0/device/gpu_busy_percent")]) + (sysmon-gpu-percent-set! mon (exact->inexact (parse-int (string-trim s))))))] + [(nvidia-smi) + (gpu-throttled-update! mon + (lambda () + (run-and-read-line + "nvidia-smi --query-gpu=utilization.gpu --format=csv,noheader,nounits 2>/dev/null" + (lambda (line) (and line (exact->inexact (parse-int (string-trim line))))))))] + [else (sysmon-gpu-percent-set! mon #f)])) + + (define (linux-have-cmd? name) + (run-and-read-line + (string-append "command -v " name " >/dev/null 2>&1 && echo y") + (lambda (line) (and (string? line) (string=? line "y"))))) + + ;; ===== macOS ===== + + (define *mac-host* #f) + (define *mac-page-size* #f) + + (define (mac-init!) + (unless *mac-host* + (let ([fp (foreign-procedure "mach_host_self" () unsigned-32)]) + (set! *mac-host* (fp)))) + (unless *mac-page-size* + (set! *mac-page-size* (or (sysctl-u64 "hw.pagesize") 16384)))) + + ;; HOST_CPU_LOAD_INFO = 3, count = 4 (CPU_STATE_MAX). + ;; Returns vector #(user system idle nice) of natural_t (uint32) ticks. + (define (mac-host-cpu-load) + (guard (e [#t #f]) + (let* ([buf (make-bytevector (* 4 4) 0)] + [cnt (make-bytevector 4 0)]) + (bytevector-u32-native-set! cnt 0 4) + (let ([rc ((foreign-procedure "host_statistics" + (unsigned-32 int u8* u8*) int) + *mac-host* 3 buf cnt)]) + (and (= rc 0) + (vector (bytevector-u32-native-ref buf 0) + (bytevector-u32-native-ref buf 4) + (bytevector-u32-native-ref buf 8) + (bytevector-u32-native-ref buf 12))))))) + + ;; HOST_VM_INFO64 = 4, count = 38. + (define (mac-host-vm-info) + (guard (e [#t #f]) + (let* ([n 38] + [buf (make-bytevector (* 4 n) 0)] + [cnt (make-bytevector 4 0)]) + (bytevector-u32-native-set! cnt 0 n) + (let ([rc ((foreign-procedure "host_statistics64" + (unsigned-32 int u8* u8*) int) + *mac-host* 4 buf cnt)]) + (and (= rc 0) buf))))) + + (define (vm-natural-ref buf idx) + (bytevector-u32-native-ref buf (* idx 4))) + + (define (mac-update-cpu! mon) + (let ([v (mac-host-cpu-load)]) + (when v + (let* ([user (vector-ref v 0)] + [sys (vector-ref v 1)] + [idle (vector-ref v 2)] + [nice (vector-ref v 3)]) + (compute-cpu-pct! mon idle (+ user sys idle nice)))))) + + (define (mac-update-mem! mon) + (let ([total (sysctl-u64 "hw.memsize")] + [buf (mac-host-vm-info)]) + (when total + (sysmon-mem-total-set! mon total)) + (when (and total buf) + ;; Used ≈ (active + wire + compressor) * pagesize — Activity-Monitor-ish. + ;; Indices: active=1, wire=3, compressor_page_count=32 in vm_statistics64. + (let* ([active (vm-natural-ref buf 1)] + [wire (vm-natural-ref buf 3)] + [compr (vm-natural-ref buf 32)]) + (sysmon-mem-used-set! mon + (* (+ active wire compr) *mac-page-size*)))))) + + ;; macOS GPU: parse `ioreg -rd1 -c IOAccelerator`, look for + ;; "Device Utilization %"=NN. Apple Silicon reports this without root. + (define (mac-update-gpu! mon) + (when (eq? (sysmon-gpu-method mon) 'unknown) + (sysmon-gpu-method-set! mon 'ioreg)) + (gpu-throttled-update! mon + (lambda () + (run-and-collect "ioreg -rd1 -c IOAccelerator 2>/dev/null" + (lambda (lines) + (let loop ([ls lines]) + (cond + [(null? ls) #f] + [(extract-pct-after-key (car ls) "Device Utilization %")] + [(extract-pct-after-key (car ls) "GPU Busy")] + [else (loop (cdr ls))]))))))) + + (define (extract-pct-after-key line key) + (let* ([slen (string-length line)] + [klen (string-length key)]) + (and (>= slen klen) + (let scan ([i 0]) + (cond + [(> (+ i klen) slen) #f] + [(string=? key (substring line i (+ i klen))) + (let next ([j (+ i klen)]) + (cond + [(>= j slen) #f] + [(char-numeric? (string-ref line j)) + (let read-num ([k j] [acc 0]) + (cond + [(or (>= k slen) + (not (char-numeric? (string-ref line k)))) + (exact->inexact acc)] + [else + (read-num (+ k 1) + (+ (* acc 10) + (- (char->integer (string-ref line k)) + (char->integer #\0))))]))] + [else (next (+ j 1))]))] + [else (scan (+ i 1))]))))) + + ;; Throttle expensive GPU sampling: take a fresh sample every N updates, + ;; reuse the cached value otherwise. N=4 → sample every 5th call. + (define (gpu-throttled-update! mon sampler) + (let ([t (sysmon-gpu-skip mon)]) + (cond + [(<= t 0) + (sysmon-gpu-percent-set! mon (sampler)) + (sysmon-gpu-skip-set! mon 4)] + [else + (sysmon-gpu-skip-set! mon (- t 1))]))) + + ;; ===== FreeBSD / OpenBSD / NetBSD ===== + + (define *bsd-page-size* #f) + + (define (bsd-init!) + (unless *bsd-page-size* + (set! *bsd-page-size* (or (sysctl-u64 "hw.pagesize") 4096)))) + + ;; kern.cp_time on FreeBSD = long[5]: user, nice, sys, intr, idle. + (define (bsd-update-cpu! mon) + (guard (e [#t (void)]) + (let ([buf (sysctl-read "kern.cp_time" (* 8 5))]) + (when buf + (let* ([user (bytevector-u64-native-ref buf 0)] + [nice (bytevector-u64-native-ref buf 8)] + [sys (bytevector-u64-native-ref buf 16)] + [intr (bytevector-u64-native-ref buf 24)] + [idle (bytevector-u64-native-ref buf 32)]) + (compute-cpu-pct! mon idle (+ user nice sys intr idle))))))) + + (define (bsd-update-mem! mon) + (let ([total (or (sysctl-u64 "hw.physmem") (sysctl-u64 "hw.realmem"))] + [active (sysctl-u32 "vm.stats.vm.v_active_count")] + [wire (sysctl-u32 "vm.stats.vm.v_wire_count")]) + (when total (sysmon-mem-total-set! mon total)) + (when (and active wire) + (sysmon-mem-used-set! mon (* (+ active wire) *bsd-page-size*))))) + + ;; ===== Process helpers ===== + + (define (run-and-read-line cmd parser) + (guard (e [#t #f]) + (let-values ([(p o e pid) (open-process-ports cmd 'block (make-transcoder (utf-8-codec)))]) + (let ([line (let ([l (get-line o)]) + (if (eof-object? l) #f l))]) + (close-port p) (close-port o) (close-port e) + (parser line))))) + + (define (run-and-collect cmd parser) + (guard (e [#t #f]) + (let-values ([(p o e pid) (open-process-ports cmd 'block (make-transcoder (utf-8-codec)))]) + (let loop ([acc '()]) + (let ([l (get-line o)]) + (cond + [(eof-object? l) + (close-port p) (close-port o) (close-port e) + (parser (reverse acc))] + [else (loop (cons l acc))])))))) + + ) ;; end library