├── LICENSE ├── README.mess ├── bsd.lisp ├── darwin.lisp ├── docs └── index.html ├── documentation.lisp ├── freebsd.lisp ├── linux.lisp ├── machine-state.asd ├── mezzano.lisp ├── nx.lisp ├── openbsd.lisp ├── opengl.lisp ├── package.lisp ├── posix.lisp ├── protocol.lisp ├── staple.ext.lisp ├── test.lisp └── windows.lisp /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2023 Yukari Hafner 2 | 3 | This software is provided 'as-is', without any express or implied 4 | warranty. In no event will the authors be held liable for any damages 5 | arising from the use of this software. 6 | 7 | Permission is granted to anyone to use this software for any purpose, 8 | including commercial applications, and to alter it and redistribute it 9 | freely, subject to the following restrictions: 10 | 11 | 1. The origin of this software must not be misrepresented; you must not 12 | claim that you wrote the original software. If you use this software 13 | in a product, an acknowledgment in the product documentation would be 14 | appreciated but is not required. 15 | 2. Altered source versions must be plainly marked as such, and must not be 16 | misrepresented as being the original software. 17 | 3. This notice may not be removed or altered from any source distribution. 18 | -------------------------------------------------------------------------------- /README.mess: -------------------------------------------------------------------------------- 1 | ## About machine-state 2 | This library implements various functions to access status information about the machine, process, etc. 3 | 4 | ## How To 5 | Since this is a toolkit library, please simply refer to the symbol index for available functions and their behaviour. The following groups of functions are available: 6 | 7 | - Process 8 | - ``process-info`` 9 | - ``process-io-bytes`` 10 | - ``process-room`` 11 | - ``process-time`` 12 | - ``process-priority`` 13 | - Threads 14 | - ``thread-time`` 15 | - ``thread-core-mask`` 16 | - ``thread-priority`` 17 | - Implementation 18 | - ``gc-room`` 19 | - ``gc-time`` 20 | - ``static-room`` 21 | - ``stack-room`` 22 | - GPU 23 | - ``gpu-info`` 24 | - ``gpu-room`` 25 | - ``gpu-time`` 26 | - Physical Machine 27 | - ``machine-info`` 28 | - ``machine-room`` 29 | - ``machine-cores`` 30 | - ``machine-uptime`` 31 | - ``machine-time`` 32 | - ``machine-battery`` 33 | - Storage Devices 34 | - ``storage-device`` 35 | - ``storage-device-path`` 36 | - ``storage-room`` 37 | - ``storage-io-bytes`` 38 | - Network Devices 39 | - ``network-info`` 40 | - ``network-devices`` 41 | - ``network-io-bytes`` 42 | 43 | ## Implementation Support 44 | Fetching information about threads that aren't the current one, or GC related information requires implementation support. The following implementations are fully or partially supported: 45 | 46 | - CCL 47 | - Clasp 48 | - ECL 49 | - SBCL 50 | - Mezzano 51 | 52 | ## Operating System Support 53 | Fetching information about various hardware devices is, of course, OS dependent. The following systems are fully or partially supported: 54 | 55 | - FreeBSD 56 | - Linux 57 | - MacOS (darwin) 58 | - Mezzano 59 | - OpenBSD 60 | - Other BSDs (POSIX) 61 | - Windows 62 | -------------------------------------------------------------------------------- /bsd.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.machine-state) 2 | 3 | (defmacro with-gensyms (syms &body body) 4 | `(let ,(mapcar (lambda (sym) `(,sym (gensym (symbol-name ',sym)))) syms) 5 | ,@body)) 6 | 7 | #-openbsd 8 | (cffi:defcvar (errno "errno") :int64) 9 | 10 | (defun strncmp-lisp (foreign-str lisp-str &key (max-chars (length lisp-str))) 11 | (= 0 (cffi:foreign-funcall "strncmp" :pointer foreign-str :string lisp-str :size max-chars :int))) 12 | 13 | (defun errno () 14 | #-openbsd errno 15 | ;; errno is a thread local in openbsd, simple (defcvar errno) won't work 16 | ;; https://github.com/openbsd/src/blob/master/lib/libc/gen/errno.c#L57 17 | ;; https://github.com/openbsd/src/blob/master/include/errno.h#L54 18 | #+openbsd (cffi:mem-ref (cffi:foreign-funcall "__errno" (:pointer :int)) :int)) 19 | 20 | (defun strerror (&optional (errno (errno))) 21 | (cffi:foreign-funcall "strerror" :int errno :string)) 22 | 23 | (defmacro posix-call (function &rest args) 24 | (with-gensyms (%val) 25 | `(let ((,%val (cffi:foreign-funcall ,function ,@args))) 26 | (if (< ,%val 0) 27 | (fail (strerror) ,function) 28 | ,%val)))) 29 | 30 | #+freebsd 31 | (progn 32 | (defun count-fields (str separator) 33 | (reduce (lambda (count ch) 34 | (if (char= ch separator) 35 | (1+ count) 36 | count)) 37 | str 38 | :initial-value 1)) 39 | 40 | (defun sysctl-name-to-mib (name &optional (mibn (count-fields name #\.))) 41 | (cffi:with-foreign-objects ((mibp :int mibn) (sizep :size)) 42 | (setf (cffi:mem-ref sizep :size) mibn) 43 | (cffi:foreign-funcall "sysctlnametomib" :string name (:pointer :int) mibp (:pointer :size) sizep) 44 | (loop for i below mibn collect (cffi:mem-aref mibp :int i)))) 45 | 46 | (defun sysctl-resolve-mib (mib) 47 | (etypecase mib 48 | (string (sysctl-name-to-mib mib)) 49 | (list (mapcan (lambda (x) 50 | (etypecase x 51 | (string (sysctl-name-to-mib x)) 52 | (number (list x)))) 53 | mib))))) 54 | 55 | #+openbsd 56 | (defun sysctl-resolve-mib (mib) mib) 57 | 58 | (cffi:defcfun ("sysctl" c-sysctl) :int 59 | (mib (:pointer :int)) 60 | (mibn :uint) 61 | (old :pointer) 62 | (oldlen (:pointer :size)) 63 | (new :pointer) 64 | (newlen :size)) 65 | 66 | (defun sysctl (mib out out-size &optional (handle-error t)) 67 | (setf mib (sysctl-resolve-mib mib)) 68 | (let ((mibn (length mib))) 69 | 70 | (cffi:with-foreign-objects ((%mib :int mibn) (oldlen :size)) 71 | (loop 72 | for name in mib and i from 0 73 | do (setf (cffi:mem-aref %mib :int i) name)) 74 | 75 | (when out 76 | (setf (cffi:mem-ref oldlen :size) out-size)) 77 | 78 | (let ((ret (c-sysctl %mib mibn (or out (cffi:null-pointer)) oldlen (cffi:null-pointer) 0))) 79 | (when (and handle-error (< ret 0)) 80 | (fail (strerror) "sysctl")) 81 | (values (or out (cffi:mem-ref oldlen :int)) ret))))) 82 | 83 | (defmacro with-sysctl ((mib out type &optional (count 1)) &body body) 84 | "Utility for SYSCTL, MIB is evaluated into a list." 85 | (with-gensyms (%mib %count) 86 | `(let* ((,%mib ,(etypecase mib 87 | (list `(list ,@mib)) 88 | (string `(list ,mib)) 89 | (t mib))) 90 | (,%count ,count)) 91 | (cffi:with-foreign-object (,out ,type ,%count) 92 | (sysctl ,%mib ,out (* ,%count (cffi:foreign-type-size ,type))) 93 | ,@body)))) 94 | 95 | (defmacro with-sysctls ((&rest sysctls) &body body) 96 | "Like with sysctl, but allows for multiple at once." 97 | (if sysctls 98 | `(with-sysctl (,@(car sysctls)) 99 | (with-sysctls (,@(cdr sysctls)) ,@body)) 100 | `(progn ,@body))) 101 | 102 | (defun sysctl-unchecked (mib out out-size) 103 | "Like SYSCTL but don't handle the ERRNO, the return value of SYSCTL is in the second value. 104 | Useful for when ERRNO has special meanings." 105 | (sysctl mib out out-size nil)) 106 | 107 | (defun sysctl-size (mib) 108 | "Call sysctl for the size of what would be returned with MIB, in bytes" 109 | (sysctl mib nil nil t)) 110 | 111 | (defun sysctl-ref (mib type &optional (offset 0)) 112 | (with-sysctl (mib out type) 113 | (cffi:mem-ref out type offset))) 114 | 115 | (defun sysctl-string (mib size) 116 | "Like SYSCTL but return a string of SIZE characters." 117 | (with-sysctl (mib str :char size) 118 | (cffi:foreign-string-to-lisp str :max-chars size))) 119 | 120 | #+32-bit 121 | (cffi:defcstruct (timeval :conc-name timeval-) 122 | (sec :uint32) 123 | (usec :uint32)) 124 | 125 | #+64-bit 126 | (cffi:defcstruct (timeval :conc-name timeval-) 127 | (sec :uint64) 128 | (usec :uint64)) 129 | 130 | (defun timeval->seconds (tv) 131 | (+ (timeval-sec tv) 132 | (/ (timeval-usec tv) 1000000.0d0))) 133 | 134 | (defconstant +unix-epoch+ (encode-universal-time 0 0 0 1 1 1970 0)) 135 | (defun get-unix-time () (- (get-universal-time) +unix-epoch+)) 136 | 137 | ;;;; https://github.com/freebsd/freebsd-src/blob/main/sys/sys/time.h#L480 138 | ;;;; https://github.com/openbsd/src/blob/master/sys/sys/time.h#L157 139 | (cffi:defcstruct (clockinfo :size #+openbsd 16 140 | #+freebsd 20 ;; FreeBSD has a reserved field 141 | :conc-name clockinfo-) 142 | (hz :int)) 143 | 144 | (defun getpid () (cffi:foreign-funcall "getpid" :long)) ;; pid_t 145 | (defun page-size () (cffi:foreign-funcall "getpagesize" :int)) 146 | 147 | (defconstant +maxcomlen+ 148 | #+openbsd 24 ;; Actually _MAXCOMLEN, https://github.com/openbsd/src/blob/master/sys/sys/sysctl.h#L363 149 | #+freebsd 19) ;; https://github.com/freebsd/freebsd-src/blob/main/sys/sys/param.h#L125 150 | 151 | (defun process-nice->priority (value) 152 | (cond ((< value -8) :realtime) 153 | ((< value 0) :high) 154 | ((= value 0) :normal) 155 | ((< value +8) :low) 156 | (T :idle))) 157 | 158 | (defun priority->process-nice (priority) 159 | (ecase priority 160 | (:idle 19) 161 | (:low 5) 162 | (:normal 0) 163 | (:high -5) 164 | (:realtime -20))) 165 | 166 | (defun split-path (path &optional (delimiter #\:)) 167 | (let (paths start) 168 | (do ((i 0 (1+ i))) 169 | ((= i (length path)) (nreverse paths)) 170 | (when (char= (schar path i) delimiter) 171 | (push (subseq path (or start 0) i) paths) 172 | (setf start (1+ i)))))) 173 | 174 | (defun resolve-executable (command) 175 | (let ((path (cffi:foreign-funcall "getenv" :string "PATH" :string))) 176 | (when path 177 | (dolist (dir (split-path path #\:)) 178 | (let ((exec-path (make-pathname 179 | :defaults (pathname-utils:parse-native-namestring dir :as :directory) 180 | :name command))) 181 | (when (probe-file exec-path) 182 | (return-from resolve-executable exec-path))))))) 183 | 184 | (defun uid->user (uid) (cffi:foreign-funcall "user_from_uid" :uint32 uid :int 1 :string)) 185 | (defun gid->group (gid) (cffi:foreign-funcall "group_from_gid" :uint32 gid :int 1 :string)) 186 | 187 | #+openbsd 188 | (cffi:defcstruct (stat :size #+32-bit 108 189 | #+64-bit 128 190 | :conc-name stat-) 191 | (mode :int :offset 0) ;; st_mode 192 | (dev :int :offset 4)) ;; st_dev 193 | 194 | #+freebsd 195 | (cffi:defcstruct (stat :size #+64-bit 224 196 | #+32-bit 208 197 | :conc-name stat-) 198 | (dev :int :offset 0) ;; st_dev 199 | (mode :int :offset 24)) ;; st_mode 200 | 201 | (defconstant +mnt-wait+ 1) 202 | (defconstant +mnt-nowait+ 2) 203 | 204 | (defun pathname-force-file (path) 205 | (cond 206 | ((pathname-utils:root-p path) path) 207 | ((pathname-utils:file-p path) path) 208 | (T (let ((directories (pathname-directory path))) 209 | (make-pathname :defaults path 210 | :directory (butlast directories) 211 | :name (car (last directories))))))) 212 | 213 | (defun find-mount-root (path) 214 | (labels ((dev-id (path) 215 | (cffi:with-foreign-objects ((stat '(:struct stat))) 216 | (posix-call "stat" :string (pathname-utils:native-namestring path) :pointer stat :int) 217 | (stat-dev stat))) 218 | (rec (path &optional (id (dev-id path))) 219 | (if (pathname-utils:root-p path) 220 | path 221 | (let* ((parent (pathname-utils:parent path)) 222 | (parent-id (dev-id parent))) 223 | (if (= parent-id id) 224 | (rec parent parent-id) 225 | path))))) 226 | (pathname-force-file (rec (truename path))))) 227 | 228 | (defun getfsstat (buf &optional (count 0) (wait? t)) 229 | (let* ((flags (if wait? +mnt-wait+ +mnt-nowait+)) 230 | (bufsize (* count (cffi:foreign-type-size '(:struct statfs))))) 231 | (posix-call "getfsstat" :pointer (or buf (cffi:null-pointer)) :size bufsize :int flags :int))) 232 | 233 | (defun mount-count () 234 | (getfsstat nil)) 235 | 236 | (defmacro do-filesystems ((fs) &body body) 237 | (with-gensyms (statfs count i) 238 | `(let ((,count (mount-count))) 239 | (cffi:with-foreign-object (,statfs '(:struct statfs) ,count) 240 | (getfsstat ,statfs ,count) 241 | (or (dotimes (,i ,count) 242 | (let ((,fs (cffi:mem-aptr ,statfs '(:struct statfs) ,i))) 243 | ,@body)) 244 | (fail "Filesystem not found")))))) 245 | 246 | ;;;; https://github.com/openbsd/src/blob/master/include/ifaddrs.h#L31 247 | ;;;; https://github.com/freebsd/freebsd-src/blob/main/include/ifaddrs.h#L32 248 | (cffi:defcstruct (ifaddrs :conc-name ifaddrs-) 249 | (next (:pointer (:struct ifaddrs))) ;; ifa_next 250 | (name :string) ;; ifa_name 251 | (flags :uint) ;; ifa_flags 252 | (address :pointer) ;; ifa_addr 253 | (netmask :pointer) ;; ifa_netmask 254 | (destination :pointer) ;; ifa_dstaddr/ifa_broadaddr 255 | (data :pointer)) ;; ifa_data 256 | 257 | (cffi:defcstruct (sockaddr :conc-name sockaddr-) 258 | (length :uint8) ;; sa_len 259 | (family :uint8) ;; sa_family 260 | (data (:array :char 14))) ;; sa_data 261 | 262 | (cffi:defcstruct (sockaddr-dl :size #+openbsd 32 263 | #+freebsd 54 264 | :conc-name sockaddr-dl-) 265 | (interface-name-length :unsigned-char :offset 5) ;; sdl_nlen 266 | (address-length :unsigned-char :offset 6) ;; sdl_alen 267 | (data (:array :unsigned-char #+openbsd 24 #+freebsd 46) :offset 8)) ;; sdl_data 268 | 269 | (defun sockaddr-dl-address (dl) 270 | (let* ((addr-start (sockaddr-dl-interface-name-length dl)) 271 | (addr-length (sockaddr-dl-address-length dl))) 272 | (if (= 0 addr-length) 273 | nil 274 | (subseq (sockaddr-dl-data dl) addr-start (+ addr-start addr-length))))) 275 | 276 | (cffi:defcstruct (sockaddr4 :size 16 :conc-name sockaddr4-) 277 | (family :ushort :offset 1) 278 | (port :uint16 :offset 2) 279 | (addr (:array :uint8 4) :offset 4)) 280 | 281 | ;;;; https://github.com/freebsd/freebsd-src/blob/main/sys/netinet6/in6.h#L128 282 | (cffi:defcstruct (sockaddr6 :size 28 :conc-name sockaddr6-) 283 | (family :ushort :offset 1) 284 | (port :uint16 :offset 2) 285 | (addr (:array :uint8 16) :offset 8)) 286 | 287 | (defconstant +af-link+ 18) 288 | (defconstant +af-inet+ 2) 289 | (defconstant +af-inet6+ #+openbsd 24 #+freebsd 28) 290 | 291 | (defmacro do-ifaddrs ((ifaptr) &body body) 292 | (with-gensyms (ifap) 293 | `(cffi:with-foreign-object (,ifap :pointer) 294 | (posix-call "getifaddrs" :pointer ,ifap :int) 295 | (let ((,ifap (cffi:mem-ref ,ifap :pointer))) 296 | (unwind-protect 297 | (do ((,ifaptr ,ifap (ifaddrs-next ,ifaptr))) 298 | ((cffi:null-pointer-p ,ifaptr) nil) 299 | ,@body) 300 | (cffi:foreign-funcall "freeifaddrs" :pointer ,ifap)))))) 301 | 302 | (define-implementation network-devices () 303 | (let ((names nil)) 304 | (do-ifaddrs (ifaddr) 305 | (pushnew (ifaddrs-name ifaddr) names :test #'string=)) 306 | (nreverse names))) 307 | 308 | (defun ipv4->string (ipv4) 309 | (format nil "~{~d~^.~}" (coerce ipv4 'list))) 310 | 311 | (defun macaddr->string (macaddr) 312 | (format nil "~{~2,'0x~^:~}" (coerce macaddr 'list))) 313 | 314 | (defun ipv6->string (ipv6) 315 | (labels ((fmt-byte (x) (format nil "~2,'0x" x)) 316 | (fmt-segment (x y) (format nil "~a~a" (fmt-byte x) (fmt-byte y)))) 317 | (format nil "~{~a~^:~}" 318 | (loop 319 | for (x y) on (coerce ipv6 'list) by #'cddr 320 | collect (fmt-segment x y))))) 321 | 322 | (define-implementation network-address (device) 323 | (let (ipv4 ipv6 mac) 324 | (do-ifaddrs (ifaddr) 325 | (when (string= device (ifaddrs-name ifaddr)) 326 | (let* ((sockaddr (ifaddrs-address ifaddr)) 327 | (address-family (sockaddr-family sockaddr))) 328 | (case address-family 329 | (#.+af-inet+ (unless ipv4 (setf ipv4 (ipv4->string (sockaddr4-addr sockaddr))))) 330 | (#.+af-inet6+ (unless ipv6 (setf ipv6 (ipv6->string (sockaddr6-addr sockaddr))))) 331 | (#.+af-link+ 332 | (unless mac 333 | (let ((addr (sockaddr-dl-address sockaddr))) 334 | (when addr 335 | (setf mac (macaddr->string addr)))))))))) 336 | (values ipv4 ipv6 mac))) 337 | 338 | (defconstant +o-rdonly+ 0) 339 | (defconstant +o-wronly+ 1) 340 | (defconstant +o-rdwr+ 2) 341 | 342 | (defmacro with-fd ((fd file &key (direction :input)) &body body) 343 | `(let ((,fd (posix-call "open" 344 | :string (pathname-utils:native-namestring ,file) 345 | :int ,(ecase direction 346 | (:input +o-rdonly+) 347 | (:output +o-wronly+) 348 | (:io +o-rdwr+)) 349 | :int))) 350 | (unwind-protect 351 | (progn ,@body) 352 | (posix-call "close" :int ,fd :int)))) 353 | -------------------------------------------------------------------------------- /darwin.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.machine-state) 2 | 3 | (defmacro sysctl (prop type &body body) 4 | `(cffi:with-foreign-objects ((ret ',type) 5 | (size :size)) 6 | (setf (cffi:mem-ref size :size) (cffi:foreign-type-size ',type)) 7 | (let ((status (cffi:foreign-funcall "sysctlbyname" :string ,prop :pointer ret :pointer size :pointer (cffi:null-pointer) :size 0 :int))) 8 | (cond ((/= 0 status) 9 | (fail (cffi:foreign-funcall "strerror" :int64 status :string))) 10 | (T ,@body))))) 11 | 12 | #++ 13 | (define-implementation process-io-bytes () 14 | ) 15 | 16 | #++ 17 | (define-implementation process-room () 18 | ) 19 | 20 | (cffi:defcstruct (vm-statistics :conc-name vm-statistics-) 21 | (free-count :uint32) 22 | (active-count :uint32) 23 | (inactive-count :uint32) 24 | (wire-count :uint32) 25 | (zero-fill-count :uint64) 26 | (reactivations :uint64) 27 | (page-ins :uint64) 28 | (page-outs :uint64) 29 | (faults :uint64) 30 | (cow-faults :uint64) 31 | (lookups :uint64) 32 | (hits :uint64) 33 | (purges :uint64) 34 | (purgeable-count :uint32) 35 | (speculative-count :uint32) 36 | (decompressions :uint64) 37 | (compressions :uint64) 38 | (swap-ins :uint64) 39 | (swap-outs :uint64) 40 | (compressor-page-count :uint32) 41 | (throttled-count :uint32) 42 | (external-page-count :uint32) 43 | (internal-page-count :uint32) 44 | (total-uncompressed-pages-in-compressor :uint64)) 45 | 46 | (define-implementation machine-room () 47 | (cffi:with-foreign-objects ((stats '(:struct vm-statistics)) 48 | (count :uint)) 49 | (setf (cffi:mem-ref count :uint) 50 | (/ (cffi:foreign-type-size '(:struct vm-statistics)) 51 | (cffi:foreign-type-size :int32))) 52 | (cond ((/= 0 (cffi:foreign-funcall "host_statistics64" 53 | :size (cffi:foreign-funcall "mach_host_self" :size) 54 | :int 4 ; HOST_VM_INFO64 55 | :pointer stats 56 | :pointer count 57 | :int)) 58 | (fail "Failed to retrieve host statistics")) 59 | (T 60 | (let* ((free-pages (vm-statistics-free-count stats)) 61 | (free (* (cffi:foreign-funcall "getpagesize" :int) free-pages)) 62 | (total (sysctl "hw.memsize" :int64 (cffi:mem-ref ret :int64)))) 63 | (values (- total free) total)))))) 64 | 65 | (define-implementation machine-uptime () 66 | (sysctl "kern.boottime" (:struct timeval) 67 | (- (- (get-universal-time) 68 | (encode-universal-time 0 0 0 1 1 1970 0)) 69 | (timeval-sec ret)))) 70 | 71 | (define-implementation machine-cores () 72 | (sysctl "hw.ncpu" :uint (cffi:mem-ref ret :uint))) 73 | 74 | #++ 75 | (define-implementation storage-device (path) 76 | ) 77 | 78 | #++ 79 | (define-implementation storage-device-path (path) 80 | ) 81 | 82 | (cffi:defcstruct (statvfs :size 64 :conc-name statvfs-) 83 | (bsize :uint64 :offset 0) 84 | (frsize :uint64 :offset 8) 85 | (blocks :uint32 :offset 16) 86 | (bfree :uint32 :offset 20) 87 | (bavail :uint32 :offset 24) 88 | (files :uint32 :offset 28) 89 | (ffree :uint32 :offset 32) 90 | (favail :uint32 :offset 36) 91 | (fsid :uint64 :offset 40) 92 | (flag :uint64 :offset 48) 93 | (namemax :uint64 :offset 56)) 94 | 95 | (define-implementation storage-room (path) 96 | (when (stringp path) 97 | (setf path (storage-device-path path))) 98 | (cffi:with-foreign-objects ((statvfs '(:struct statvfs))) 99 | (posix-call "statvfs" :string (pathname-utils:native-namestring path) :pointer statvfs :int) 100 | (values (* (statvfs-bavail statvfs) 101 | (statvfs-bsize statvfs)) 102 | (* (statvfs-blocks statvfs) 103 | (statvfs-bsize statvfs))))) 104 | 105 | #++ 106 | (define-implementation storage-io-bytes (device) 107 | (when (pathnamep device) 108 | (setf device (storage-device device))) 109 | ) 110 | 111 | #++ 112 | (define-implementation network-io-bytes (device) 113 | ) 114 | -------------------------------------------------------------------------------- /docs/index.html: -------------------------------------------------------------------------------- 1 | Machine State

machine state

1.2.0

Retrieve machine state information about CPU time, memory usage, etc.

Table of Contents

About machine-state

This library implements various functions to access status information about the machine, process, etc.

How To

Since this is a toolkit library, please simply refer to the symbol index for available functions and their behaviour. The following groups of functions are available:

Implementation Support

Fetching information about threads that aren't the current one, or GC related information requires implementation support. The following implementations are fully or partially supported:

  • CCL

  • Clasp

  • ECL

  • SBCL

  • Mezzano

Operating System Support

Fetching information about various hardware devices is, of course, OS dependent. The following systems are fully or partially supported:

  • BSDs (POSIX)

  • Linux

  • MacOS (darwin)

  • Mezzano

  • Windows

System Information

1.2.0
Yukari Hafner
zlib
https://shinmera.github.io/machine-state/
https://github.com/shinmera/machine-state/issues
https://github.com/shinmera/machine-state.git

Definition Index

-------------------------------------------------------------------------------- /documentation.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.machine-state) 2 | 3 | (docs:define-docs 4 | (type query-failed 5 | "Error signalled if a query should fail for some reason. 6 | 7 | This condition is *NOT* signalled if the function is simply 8 | unsupported. It is however signalled if an OS call failed for some 9 | reason such as lack of access permissions.") 10 | 11 | (function process-io-bytes 12 | "Returns the number of bytes of IO performed by the process. 13 | 14 | Returns three values: 15 | The total number of IO bytes performed. 16 | The bytes read. 17 | The bytes written. 18 | 19 | IO in this context refers to any activity to external devices such as 20 | drives, networking, etc. 21 | 22 | If the function is unsupported a constant 0 is returned for all 23 | values. 24 | 25 | See STORAGE-IO-BYTES 26 | See NETWORK-IO-BYTES") 27 | 28 | (function process-time 29 | "Returns the amount of processing time spent by this process in seconds. 30 | 31 | This does not include time spent in the kernel. 32 | 33 | If the function is unsupported a constant 0.0d0 is returned. 34 | 35 | See MACHINE-TIME 36 | See THREAD-TIME 37 | See GC-TIME 38 | See GPU-TIME") 39 | 40 | (function process-room 41 | "Returns the process' memory usage statistics. 42 | 43 | This includes foreign memory usage. 44 | 45 | Returns the number of bytes occupied. 46 | 47 | If the function is unsupported a constant 0 is returned. 48 | 49 | See MACHINE-ROOM 50 | See GC-ROOM 51 | See GPU-ROOM 52 | See STATIC-ROOM 53 | See STACK-ROOM 54 | See STORAGE-ROOM") 55 | 56 | (function machine-room 57 | "Returns the machine's primary memory usage statistics. 58 | 59 | Returns two values: 60 | The number of physical bytes occupied 61 | The total number of physical bytes available 62 | 63 | If the function is unsupported a constant 0 is returned for all 64 | values. 65 | 66 | See PROCESS-ROOM 67 | See GC-ROOM 68 | See GPU-ROOM 69 | See STATIC-ROOM 70 | See STACK-ROOM 71 | See STORAGE-ROOM") 72 | 73 | (function machine-cores 74 | "Returns the number of cores available on the machine. 75 | 76 | If the function is unsupported a constant 1 is returned. 77 | 78 | See THREAD-CORE-MASK") 79 | 80 | (function machine-uptime 81 | "Returns the number of seconds since the machine was started up. 82 | 83 | If the function is unsupported a constant 0 is returned.") 84 | 85 | (function machine-time 86 | "Returns the amount of time spent processing. 87 | 88 | Core may be T for an aggregate of all cores, or an integer of the core number. 89 | 90 | Returns two values: 91 | The time spent idle in seconds 92 | The total time spent in seconds 93 | 94 | If the function is unsupported a constant 0.0d0 is returned. 95 | 96 | See MACHINE-CORES") 97 | 98 | (function thread-time 99 | "Returns the amount of processing time spent by this thread in seconds. 100 | 101 | This does not include time spent in the kernel. 102 | 103 | Thread may be T for the current thread, or a BT:THREAD. 104 | 105 | If the function is unsupported a constant 0.0d0 is returned. 106 | 107 | See MACHINE-TIME 108 | See PROCESS-TIME 109 | See GC-TIME 110 | See GPU-TIME") 111 | 112 | (function thread-core-mask 113 | "Accessor to the CPU core affinity mask of the thread. 114 | 115 | The mask is a bitfield where each set bit in the integer designates a 116 | core that the thread may be executed on. For compatibility reasons 117 | only integers up to 64 bits are supported. 118 | 119 | Thread may be T for the current thread, or a BT:THREAD. 120 | 121 | If the function is unsupported a constant of all 1s is returned. 122 | 123 | When setting this place, the *actual* affinity mask of the thread is 124 | returned, which may differ from the one you tried to set. 125 | 126 | See MACHINE-CORES") 127 | 128 | (function process-priority 129 | "Accessor to the scheduler priority of the process. 130 | 131 | The priority can be one of the following values, in ascending order of 132 | importance: 133 | 134 | :IDLE 135 | :LOW 136 | :NORMAL 137 | :HIGH 138 | :REALTIME 139 | 140 | If the function is unsupported :NORMAL is returned in all cases. 141 | 142 | When setting this place, the *actual* priority of the process is 143 | returned, which may differ from the one you tried to set. 144 | 145 | See THREAD-PRIORITY") 146 | 147 | (function thread-priority 148 | "Accessor to the scheduler priority of the thread. 149 | 150 | The priority can be one of the following values, in ascending order of 151 | importance: 152 | 153 | :IDLE 154 | :LOW 155 | :NORMAL 156 | :HIGH 157 | :REALTIME 158 | 159 | Thread may be T for the current thread, or a BT:THREAD. 160 | 161 | If the function is unsupported :NORMAL is returned in all cases. 162 | 163 | When setting this place, the *actual* priority of the thread is 164 | returned, which may differ from the one you tried to set. 165 | 166 | See PROCESS-PRIORITY") 167 | 168 | (function gc-room 169 | "Returns the GC's memory usage statistics. 170 | 171 | This does not include foreign memory usage. 172 | 173 | Returns two values: 174 | The number of free bytes 175 | The total number of bytes available 176 | 177 | If the function is unsupported a constant 0 is returned for both 178 | values. 179 | 180 | See MACHINE-ROOM 181 | See PROCESS-ROOM 182 | See GPU-ROOM 183 | See STATIC-ROOM 184 | See STACK-ROOM 185 | See STORAGE-ROOM") 186 | 187 | (function gc-time 188 | "Returns the amount of processing time spent in the GC. 189 | 190 | If the function is unsupported a constant 0.0d0 is returned. 191 | 192 | See MACHINE-TIME 193 | See PROCESS-TIME 194 | See GC-TIME 195 | See GPU-TIME 196 | See THREAD-TIME") 197 | 198 | (function gpu-room 199 | "Returns the GPU's memory usage statistics. 200 | 201 | Returns two values: 202 | The number of free bytes 203 | The total number of bytes available 204 | 205 | If the function is unsupported a constant 0 is returned for both 206 | values. 207 | 208 | You may want to load the machine-state/opengl library to make this 209 | function useful. In that case, it will only work if an OpenGL context 210 | is current to this thread. 211 | 212 | See MACHINE-ROOM 213 | See PROCESS-ROOM 214 | See GC-ROOM 215 | See STATIC-ROOM 216 | See STACK-ROOM 217 | See STORAGE-ROOM") 218 | 219 | (function gpu-time 220 | "Returns the amount of processing time spent on the GPU by this process. 221 | 222 | If the function is unsupported a constant 0.0d0 is returned. 223 | 224 | You may want to load the machine-state/opengl library to make this 225 | function useful. In that case, it will only work if an OpenGL context 226 | is current to this thread. 227 | 228 | See PROCESS-TIME 229 | See GC-TIME 230 | See MACHINE-TIME 231 | See THREAD-TIME") 232 | 233 | (function static-room 234 | "Returns the static space size as an integer. 235 | 236 | If the function is unsupported zero is returned. 237 | 238 | See MACHINE-ROOM 239 | See PROCESS-ROOM 240 | See GC-ROOM 241 | See GPU-ROOM 242 | See STACK-ROOM 243 | See STORAGE-ROOM") 244 | 245 | (function stack-room 246 | "Return the stack usage statistics. 247 | 248 | Returns two values: 249 | The number of free stack bytes 250 | The total stack space available 251 | 252 | See MACHINE-ROOM 253 | See PROCESS-ROOM 254 | See GC-ROOM 255 | See GPU-ROOM 256 | See STATIC-ROOM 257 | See STORAGE-ROOM") 258 | 259 | (function storage-room 260 | "Return file system storage usage statistics. 261 | 262 | The argument may either be a pathname to a file on the device to 263 | query, or the system provided name for the device. 264 | 265 | Returns two values: 266 | The number of free bytes 267 | The total number of bytes available 268 | 269 | See STORAGE-DEVICE 270 | See STORAGE-DEVICE-PATH 271 | See MACHINE-ROOM 272 | See PROCESS-ROOM 273 | See GC-ROOM 274 | See GPU-ROOM 275 | See STATIC-ROOM 276 | See STACK-ROOM") 277 | 278 | (function storage-device 279 | "Return the system device name of the device backing the path. 280 | 281 | Returns the device name as a string if it can be found and signals a 282 | QUERY-FAILED error otherwise. 283 | 284 | See STORAGE-DEVICE-PATH 285 | See STORAGE-ROOM 286 | See STORAGE-IO-BYTES") 287 | 288 | (function storage-device-path 289 | "Return a path which the storage device is backing if any. 290 | 291 | Returns the path as a directory pathname if it can be found and 292 | signals a QUERY-FAILED error otherwise. 293 | 294 | See STORAGE-DEVICE 295 | See STORAGE-ROOM 296 | See STORAGE-IO-BYTES") 297 | 298 | (function storage-io-bytes 299 | "Returns the number of bytes of IO performed on the storage device. 300 | 301 | The argument may either be a pathname to a file on the device to 302 | query, the system provided name for the device, or T to get an 303 | aggregate of all attached devices. 304 | 305 | Returns three values: 306 | The total number of IO bytes performed. 307 | The bytes read. 308 | The bytes written. 309 | 310 | If the function is unsupported a constant 0 is returned. 311 | 312 | See STORAGE-DEVICE 313 | See STORAGE-DEVICE-PATH 314 | See NETWORK-IO-BYTES 315 | See PROCESS-IO-BYTES") 316 | 317 | (function network-devices 318 | "Returns a list of network device names. 319 | 320 | If the function is unsupported an empty list is returned. 321 | 322 | See NETWORK-IO-BYTES 323 | See NETWORK-ADDRESS") 324 | 325 | (function network-io-bytes 326 | "Returns the number of bytes of IO performed on the network device. 327 | 328 | The argument may either be the system name of the device as a string 329 | or T to get an aggregate of all attached devices. 330 | 331 | Returns three values: 332 | The total number of IO bytes performed. 333 | The bytes read. 334 | The bytes written. 335 | 336 | If the function is unsupported a constant 0 is returned. 337 | 338 | See NETWORK-DEVICES 339 | See PROCESS-IO-BYTES 340 | See STORAGE-IO-BYTES") 341 | 342 | (function machine-info 343 | "Returns information about the host machine. 344 | 345 | Returns four values: 346 | The name of the vendor of the machine (or motherboard) as a string 347 | The name of the model of the machine (or motherboard) as a string 348 | The name of the operating system of the machine as a keyword: 349 | :WINDOWS 350 | :LINUX 351 | :DARWIN 352 | :ANDROID 353 | :IOS 354 | :NETBSD 355 | :FREEBSD 356 | :OPENBSD 357 | :BEOS 358 | :SOLARIS 359 | :REACT 360 | :PLAN9 361 | :MEZZANO 362 | :NX 363 | NIL 364 | The version of the operating system as a string 365 | 366 | If the function is unsupported, 367 | \"Unknown\" 368 | \"Unknown\" 369 | NIL 370 | \"Unknown\" 371 | are returned. 372 | 373 | See MACHINE-CORE-INFO 374 | See PROCESS-INFO 375 | See GPU-INFO 376 | See NETWORK-INFO") 377 | 378 | (function machine-battery 379 | "Returns information about the battery charge state, if any. 380 | 381 | Returns three values: 382 | Current charge 383 | Full charge 384 | Charging state: 385 | :CHARGING 386 | :DISCHARGING 387 | :FULL 388 | NIL 389 | 390 | If no battery is attached or the function is unsupported, 391 | 0.0d0 392 | 0.0d0 393 | NIL 394 | are returned.") 395 | 396 | (function machine-core-info 397 | "Returns information about the host machine's processor. 398 | 399 | Returns four values: 400 | The name of the vendor of the processor as a string 401 | The name of the model of the processor as a string 402 | The name of the architecture as a keyword: 403 | :X86 404 | :AMD64 405 | :ARM 406 | :ARM64 407 | :RISCV 408 | :RISCV64 409 | :PPC 410 | :SPARC 411 | NIL 412 | The version of the architecture as a string 413 | 414 | If the function is unsupported, 415 | \"Unknown\" 416 | \"Unknown\" 417 | NIL 418 | \"Unknown\" 419 | are returned. 420 | 421 | See MACHINE-INFO 422 | See PROCESS-INFO 423 | See GPU-INFO 424 | See NETWORK-INFO") 425 | 426 | (function process-info 427 | "Returns information about the current process. 428 | 429 | Returns four values: 430 | The path to the executable as a pathname 431 | The current working directory as a pathname 432 | The running user as a string or NIL 433 | The running group as a string or NIL 434 | 435 | If the function is unsupported, 436 | *default-pathname-defaults* 437 | *default-pathname-defaults* 438 | \"Unknown\" 439 | \"Unknown\" 440 | are returned. 441 | 442 | See MACHINE-INFO 443 | See MACHINE-CORE-INFO 444 | See GPU-INFO 445 | See NETWORK-INFO") 446 | 447 | (function gpu-info 448 | "Returns information about the graphics card. 449 | 450 | Returns three values: 451 | The vendor of the graphics card as a keyword: 452 | :NVIDIA 453 | :AMD (formerly ATI) 454 | :INTEL 455 | and others 456 | The model of the graphics card as a string 457 | The version of OpenGL and/or graphics card driver as a string 458 | 459 | If the function is unsupported, 460 | NIL 461 | \"Unknown\" 462 | \"Unknown\" 463 | are returned. 464 | 465 | You may want to load the machine-state/opengl library to make this 466 | function useful. In that case, it will only work if an OpenGL context 467 | is current to this thread. 468 | 469 | See MACHINE-INFO 470 | See MACHINE-CORE-INFO 471 | See PROCESS-INFO 472 | See NETWORK-INFO") 473 | 474 | (function network-info 475 | "Returns information about the machine's network state. 476 | 477 | Returns one value: 478 | The hostname of the machine as a string 479 | 480 | If the function is unsupported, 481 | NIL 482 | is returned. 483 | 484 | See MACHINE-INFO 485 | See MACHINE-CORE-INFO 486 | See PROCESS-INFO 487 | See GPU-INFO") 488 | 489 | (function network-address 490 | "Returns information about a network device's addresses. 491 | 492 | Returns three values: 493 | The device's MAC address as a string or NIL 494 | The device's IPv4 address as a string or NIL 495 | The device's IPv6 address as a string or NIL 496 | 497 | If the function is unsupported, 498 | NIL 499 | NIL 500 | NIL 501 | are returned. 502 | 503 | See NETWORK-DEVICES 504 | See NETWORK-INFO")) 505 | -------------------------------------------------------------------------------- /freebsd.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.machine-state) 2 | 3 | (define-implementation machine-room () 4 | (let ((page-size (sysctl-ref "hw.pagesize" :uint32)) 5 | (physmem (sysctl-ref "hw.physmem" :uint64)) 6 | (free (sysctl-ref "vm.stats.vm.v_free_count" :uint32))) 7 | (values (- physmem (* free page-size)) physmem))) 8 | 9 | (define-implementation machine-uptime () 10 | (with-sysctl ("kern.boottime" tv '(:struct timeval)) 11 | (- (get-unix-time) (timeval-sec tv)))) 12 | 13 | (define-implementation machine-cores () 14 | (sysctl-ref "hw.ncpu" :int)) 15 | 16 | ;;;; https://github.com/freebsd/freebsd-src/blob/main/sys/sys/resource.h#L172 17 | (defconstant +cpustates+ 5) 18 | 19 | (defun cpu-time () 20 | (sysctl-ref "kern.cp_time" `(:array :uint64 ,+cpustates+))) 21 | 22 | (defun core-time (core) 23 | (let ((size (* (machine-cores) +cpustates+))) 24 | (with-sysctl ("kern.cp_times" cpustates :uint64 size) 25 | (cffi:mem-aref cpustates `(:array :uint64 ,+cpustates+) core)))) 26 | 27 | (define-implementation machine-time (core) 28 | (with-sysctl ("kern.clockrate" clockinfo '(:struct clockinfo)) 29 | (flet ((conv (x) (/ x (float (clockinfo-hz clockinfo) 0.0d0)))) 30 | (let ((values (cond 31 | ((eq 't core) (cpu-time)) 32 | ((>= core (machine-cores)) (fail "No such core.")) 33 | (t (core-time core))))) 34 | (destructuring-bind (user nice sys intr idle) (coerce values 'list) 35 | (values (conv idle) 36 | (conv (+ user nice sys intr idle)))))))) 37 | 38 | (define-implementation machine-info () 39 | (values "Unknown" "Unknown" :freebsd (sysctl-string "kern.osrelease" 32))) 40 | 41 | (define-implementation machine-core-info () 42 | (let ((processor (sysctl-string "hw.model" 128))) 43 | (values processor 44 | processor ;; There doesn't seem to be a separation between those 45 | (arch-type) 46 | (sysctl-string "hw.machine" 32)))) 47 | 48 | (cffi:defcstruct (rusage :size 144 :conc-name rusage-) 49 | (user-time (:struct timeval)) 50 | (system-time (:struct timeval))) 51 | 52 | ;;;; https://github.com/freebsd/freebsd-src/blob/main/sys/sys/user.h#L118 53 | (cffi:defcstruct (kinfo-proc :size 1088 :conc-name kinfo-proc-) 54 | (user-id :uint32 :offset 168) ;; ki_uid 55 | (group-id :uint32 :offset 180) ;; ki_rgid 56 | (resident-set-size :int32 :offset 264) ;; ki_rssize 57 | (nice :int8 :offset 389) ;; ki_nice 58 | (command-name (:array :char #.(1+ +maxcomlen+)) :offset 447) ;; ki_comm 59 | ;; (runtime :uint64 :offset 328) ;; ki_runtime (microseconds) 60 | (thread-id :int32 :offset 600) ;; ki_tid 61 | (rusage (:struct rusage) :offset 608)) ;; ki_rusage 62 | 63 | (defmacro with-current-process ((proc) &body body) 64 | `(with-sysctl (("kern.proc.pid" (getpid)) ,proc '(:struct kinfo-proc)) 65 | ,@body)) 66 | 67 | (define-implementation process-room () 68 | (with-current-process (proc) 69 | (* (page-size) (kinfo-proc-resident-set-size proc)))) 70 | 71 | (define-implementation process-priority () 72 | (with-current-process (proc) 73 | (process-nice->priority (kinfo-proc-nice proc)))) 74 | 75 | (define-implementation process-time () 76 | (with-current-process (proc) 77 | (let* ((rusage (cffi:foreign-slot-pointer proc '(:struct kinfo-proc) 'rusage)) 78 | (tv (cffi:foreign-slot-pointer rusage '(:struct rusage) 'user-time))) 79 | (timeval->seconds tv)))) 80 | 81 | (define-implementation process-info () 82 | (with-current-process (proc) 83 | (values (let ((command (cffi:foreign-string-to-lisp 84 | (cffi:foreign-slot-pointer proc '(:struct kinfo-proc) 'command-name)))) 85 | (or (resolve-executable command) command)) 86 | (cffi:with-foreign-object (cwd :char 1024) 87 | (cffi:foreign-funcall "getcwd" (:pointer :char) cwd :size 1024) 88 | (pathname-utils:parse-native-namestring (cffi:foreign-string-to-lisp cwd :max-chars 1024) :as :directory)) 89 | (uid->user (kinfo-proc-user-id proc)) 90 | (gid->group (kinfo-proc-group-id proc))))) 91 | 92 | (defconstant +mfsnamelen+ 16) ;; https://github.com/freebsd/freebsd-src/blob/main/sys/sys/mount.h#L78 93 | (defconstant +mnamelen+ 1024) ;; https://github.com/freebsd/freebsd-src/blob/main/sys/sys/mount.h#L79 94 | 95 | ;;;; https://github.com/freebsd/freebsd-src/blob/main/sys/sys/mount.h#L81 96 | (cffi:defcstruct (statfs :size 2344 :conc-name statfs-) 97 | (block-size :uint32 :offset 16) ;; f_bsize 98 | (blocks :uint64 :offset 32) ;; f_blocks 99 | (available-blocks :int64 :offset 48) ;; f_bavail ;; Blocks available to non-superuser 100 | (fs-type (:array :char #.+mfsnamelen+) :offset 280) ;; f_fstypename 101 | (device (:array :char #.+mnamelen+) :offset 296) ;; f_mntfromname 102 | (mountpoint (:array :char #.+mnamelen+) :offset 1320)) ;; f_mntonname 103 | 104 | (define-implementation storage-device (path) 105 | (let ((mount-root (pathname-utils:native-namestring (pathname-force-file (find-mount-root path))))) 106 | (do-filesystems (fs) 107 | (let ((fs-mountpoint (cffi:foreign-slot-pointer fs '(:struct statfs) 'mountpoint))) 108 | (when (strncmp-lisp fs-mountpoint mount-root :max-chars +mnamelen+) 109 | (return (cffi:foreign-string-to-lisp 110 | (cffi:foreign-slot-pointer fs '(:struct statfs) 'device) :max-chars +mnamelen+))))))) 111 | 112 | (define-implementation storage-device-path (device) 113 | (do-filesystems (fs) 114 | (let ((fs-device (cffi:foreign-slot-pointer fs '(:struct statfs) 'device))) 115 | (when (strncmp-lisp fs-device device :max-chars +mnamelen+) 116 | (return (pathname-utils:parse-native-namestring 117 | (cffi:foreign-string-to-lisp 118 | (cffi:foreign-slot-pointer fs '(:struct statfs) 'mountpoint) :max-chars +mnamelen+))))))) 119 | 120 | (define-implementation storage-room (path) 121 | (when (stringp path) 122 | (setf path (storage-device-path path))) 123 | 124 | (let ((mount-root (pathname-utils:native-namestring (pathname-force-file (find-mount-root path))))) 125 | (do-filesystems (fs) 126 | (let ((fs-mountpoint (cffi:foreign-slot-pointer fs '(:struct statfs) 'mountpoint))) 127 | (when (strncmp-lisp fs-mountpoint mount-root :max-chars +mnamelen+) 128 | (flet ((block->bytes (n) 129 | (* n (statfs-block-size fs)))) 130 | (return-from storage-room 131 | (values (block->bytes (statfs-available-blocks fs)) 132 | (block->bytes (statfs-blocks fs)))))))))) 133 | 134 | (define-implementation network-info () 135 | (sysctl-string "kern.hostname" 255)) 136 | 137 | (cffi:defcstruct (if-data :size 152 ;; #+openbsd 136 138 | :conc-name if-data-) 139 | (ibytes :uint64 :offset 64) 140 | (obytes :uint64 :offset 72)) 141 | 142 | (define-implementation network-io-bytes (device) 143 | (let ((read 0) (written 0)) 144 | (do-ifaddrs (ifaddr) 145 | (when (string= device (ifaddrs-name ifaddr)) 146 | (let ((data (ifaddrs-data ifaddr))) 147 | (incf read (if-data-ibytes data)) 148 | (incf written (if-data-obytes data))))) 149 | (values (+ read written) read written))) 150 | 151 | ;;;; Reference: 152 | ;;;; https://github.com/freebsd/freebsd-src/blob/main/usr.sbin/acpi/acpiconf/acpiconf.c 153 | ;;;; https://github.com/freebsd/freebsd-src/blob/main/sys/dev/acpica/acpiio.h 154 | 155 | (cffi:defcstruct (acpi-battinfo :size 16)) 156 | (cffi:defcstruct (acpi-bif :size 164)) 157 | 158 | ;; https://github.com/freebsd/freebsd-src/blob/main/usr.sbin/acpi/acpiconf/acpiconf.c#L82 159 | (defconstant +unknown-cap+ #xffffffff) 160 | (defconstant +unknown-voltage+ #xffffffff) 161 | 162 | (cffi:defcstruct (acpi-bst :size 16 :conc-name acpi-bst-) 163 | (state :uint32) ;; state 164 | (rate :uint32) ;; rate 165 | (capacity :uint32) ;; cap 166 | (voltage :uint32)) ;; volts 167 | 168 | ;;;; https://github.com/freebsd/freebsd-src/blob/main/sys/dev/acpica/acpiio.h#L76 169 | (cffi:defcstruct (acpi-bix :size 256 :conc-name acpi-bix-) 170 | (units :uint32 :offset 0) ;; units 171 | (design-capacity :uint32 :offset 4) ;; dcap 172 | (last-full-capacity :uint32 :offset 8) ;; lfcap 173 | (design-volts :uint32 :offset 16)) ;; dvol 174 | 175 | ;;;; https://github.com/freebsd/freebsd-src/blob/main/sys/dev/acpica/acpiio.h#L175 176 | (cffi:defcunion acpi-battery-ioctl-arg 177 | (unit :int) 178 | (battinfo (:struct acpi-battinfo)) 179 | (bix (:struct acpi-bix)) 180 | (bif (:struct acpi-bif)) 181 | (bst (:struct acpi-bst))) 182 | 183 | (defconstant +acpi-bix-units-mw+ 0) 184 | (defconstant +acpi-bix-units-ma+ 1) 185 | (defun acpi-bix-last-full-capacity-mAh (bix) 186 | (flet ((mWh->mAh (mWh mV) 187 | (/ mWh (* 1000 mV)))) 188 | (let ((last (acpi-bix-last-full-capacity bix)) 189 | (unit (acpi-bix-units bix))) 190 | (cond 191 | ((= +unknown-cap+ last) 0.0d0) 192 | ((= +acpi-bix-units-mw+ unit) 193 | (let ((mV (acpi-bix-design-volts bix))) 194 | (if (= +unknown-voltage+ mV) 195 | 0.0d0 196 | (mWh->mAh last mV)))) 197 | ((= +acpi-bix-units-ma+ unit) last) 198 | (t 0.0d0))))) 199 | 200 | ;;;; https://github.com/freebsd/freebsd-src/blob/main/sys/dev/acpica/acpiio.h#L188 201 | (defconstant +acpiio-bat-get-bix+ 3238019600) 202 | (defconstant +acpiio-bat-get-bst+ 3238019601) 203 | 204 | (defun battery-last-full-capacity (acpifd battio battn) 205 | (setf (cffi:foreign-slot-value battio '(:union acpi-battery-ioctl-arg) 'unit) battn) 206 | (posix-call "ioctl" :int acpifd :unsigned-long +acpiio-bat-get-bix+ :pointer battio :int) 207 | (let ((bix (cffi:foreign-slot-pointer battio '(:union acpi-battery-ioctl-arg) 'bix))) 208 | (acpi-bix-last-full-capacity-mAh bix))) 209 | 210 | ;;;; https://github.com/freebsd/freebsd-src/blob/main/sys/dev/acpica/acpiio.h#L157 211 | (defconstant +acpi-batt-stat-discharg+ 1) 212 | (defconstant +acpi-batt-stat-charging+ 2) 213 | (defconstant +acpi-batt-stat-critical+ 4) 214 | (defconstant +acpi-batt-stat-invalid+ (logior +acpi-batt-stat-discharg+ +acpi-batt-stat-charging+)) 215 | (defconstant +acpi-batt-stat-bst-mask+ (logior +acpi-batt-stat-invalid+ +acpi-batt-stat-critical+)) 216 | (defconstant +acpi-batt-stat-not-present+ +acpi-batt-stat-bst-mask+) 217 | 218 | (defun battery-state (acpifd battio battn) 219 | (setf (cffi:foreign-slot-value battio '(:union acpi-battery-ioctl-arg) 'unit) battn) 220 | (posix-call "ioctl" :int acpifd :unsigned-long +acpiio-bat-get-bst+ :pointer battio :int) 221 | (let* ((bst (cffi:foreign-slot-pointer battio '(:union acpi-battery-ioctl-arg) 'bix)) 222 | (remaining-capacity (acpi-bst-capacity bst)) 223 | (state (acpi-bst-state bst))) 224 | (values (if (or (= remaining-capacity +unknown-cap+) 225 | (= remaining-capacity -1)) 226 | 0.0d0 227 | remaining-capacity) 228 | (if (= +acpi-batt-stat-not-present+ state) 229 | nil 230 | (ecase (logand state +acpi-batt-stat-bst-mask+) 231 | (0 :charging) ;; 0 is reported as "high" on acpiconf 232 | (#.+acpi-batt-stat-charging+ :charging) 233 | (#.+acpi-batt-stat-discharg+ :discharging) 234 | (t nil)))))) 235 | 236 | (define-implementation machine-battery () 237 | (with-fd (acpifd #P"/dev/acpi" :direction :input) 238 | (cffi:with-foreign-object (battio '(:union acpi-battery-ioctl-arg)) 239 | (let ((last-full-capacity (battery-last-full-capacity acpifd battio 0))) 240 | (multiple-value-bind (remaining-capacity state) (battery-state acpifd battio 0) 241 | (values (float remaining-capacity 0.0d0) 242 | (float last-full-capacity 0.0d0) 243 | ;; There doesn't seem to be a "full" state, full capacity still shows as charging 244 | ;; so detect it manually 245 | (if (= remaining-capacity last-full-capacity) 246 | :full 247 | state))))))) 248 | -------------------------------------------------------------------------------- /linux.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.machine-state) 2 | 3 | (defmacro with-proc ((file &rest fields) &body body) 4 | `(cffi:with-foreign-object (io :char 2048) 5 | (let ((file (cffi:foreign-funcall "fopen" :string ,file :string "rb" :pointer))) 6 | (when (cffi:null-pointer-p file) 7 | (fail (strerror))) 8 | (cffi:foreign-funcall "fread" :pointer io :size 1 :size 2048 :pointer file :size) 9 | (cffi:foreign-funcall "fclose" :pointer file :void)) 10 | (let ,(loop for (var field) in fields 11 | collect `(,var (let* ((field ,field) 12 | (start (cffi:foreign-funcall "strstr" :pointer io :string field :pointer)) 13 | (ptr (cffi:inc-pointer start (length field)))) 14 | (cffi:foreign-funcall "atol" :pointer ptr :long)))) 15 | ,@body))) 16 | 17 | (defmacro do-proc (vars (file fgetsspec &optional return) &body body) 18 | `(cffi:with-foreign-objects ((io :char 2048) 19 | ,@vars) 20 | (let ((file (cffi:foreign-funcall "fopen" :string ,file :string "rb" :pointer))) 21 | (when (cffi:null-pointer-p file) 22 | (fail (strerror))) 23 | (unwind-protect 24 | (loop while (/= 0 (cffi:foreign-funcall "fgets" :pointer io :size 2048 :pointer file :int)) 25 | do (when (= ,(length vars) (cffi:foreign-funcall "sscanf" :pointer io :string ,fgetsspec 26 | ,@(loop for (name) in vars collect :pointer collect name) 27 | :int)) 28 | (let ,(loop for (var type count) in vars 29 | when (null count) 30 | collect `(,var (cffi:mem-ref ,var ',type))) 31 | ,@body)) 32 | finally (progn (return ,return))) 33 | (cffi:foreign-funcall "fclose" :pointer file :void))))) 34 | 35 | (define-implementation process-io-bytes () 36 | (with-proc ("/proc/self/io" (read "rchar: ") (write "wchar: ")) 37 | (values (+ read write) read write))) 38 | 39 | ;;;; For whatever reason on Linux rusage is useless for this, so redefine it here. 40 | (define-implementation process-room () 41 | (with-proc ("/proc/self/smaps_rollup" (rss "Rss: ")) 42 | (* 1024 rss))) 43 | 44 | (define-implementation machine-time (core) 45 | (let ((scale (/ (float (posix-call "sysconf" :int 2 :long) 0d0)))) 46 | (flet ((conv (x) (* x scale))) 47 | (etypecase core 48 | ((eql T) 49 | (do-proc ((user :int) (nice :int) (system :int) (idle :int) (iowait :int) (irq :int) (softirq :int)) 50 | ("/proc/stat" "cpu %d %d %d %d %d %d %d") 51 | (return (values (conv idle) (conv (+ user nice system idle iowait irq softirq)))))) 52 | (integer 53 | (do-proc ((c :int) (user :int) (nice :int) (system :int) (idle :int) (iowait :int) (irq :int) (softirq :int)) 54 | ("/proc/stat" "cpu%d %d %d %d %d %d %d %d" (fail "No such core.")) 55 | (when (= c core) 56 | (return (values (conv idle) (conv (+ user nice system idle iowait irq softirq))))))))))) 57 | 58 | (cffi:defcstruct (stat :size 144 :conc-name stat-) 59 | (dev :uint64 :offset 0) 60 | (mode :uint32 :offset 24)) 61 | 62 | (defun pathname-force-file (path) 63 | (cond 64 | ((pathname-utils:root-p path) path) 65 | ((pathname-utils:file-p path) path) 66 | (T (let ((directories (pathname-directory path))) 67 | (make-pathname :defaults path 68 | :directory (butlast directories) 69 | :name (car (last directories))))))) 70 | 71 | (defun find-mount-root (path) 72 | (labels ((dev-id (path) 73 | (cffi:with-foreign-objects ((stat '(:struct stat))) 74 | (posix-call "stat" :string (pathname-utils:native-namestring path) :pointer stat :int) 75 | (stat-dev stat))) 76 | (rec (path &optional (id (dev-id path))) 77 | (if (pathname-utils:root-p path) 78 | path 79 | (let* ((parent (pathname-utils:parent path)) 80 | (parent-id (dev-id parent))) 81 | (if (= parent-id id) 82 | (rec parent parent-id) 83 | path))))) 84 | (pathname-force-file (rec (truename path))))) 85 | 86 | (define-implementation storage-device (path) 87 | (let* ((mount-root (pathname-utils:native-namestring (pathname-force-file (find-mount-root path))))) 88 | (do-proc ((mountpoint :char 512) (name :char 32)) 89 | ("/proc/self/mountinfo" "%*d %*d %*d:%*d / %s %*[^-]- %*s /dev/%s" 90 | (fail "Device not found in mountinfo table")) 91 | (when (= 0 (cffi:foreign-funcall "strncmp" :pointer mountpoint :string mount-root :size 32 :int)) 92 | (return (cffi:foreign-string-to-lisp name :max-chars 32)))))) 93 | 94 | (define-implementation storage-device-path (device) 95 | (do-proc ((mount :char 512) (name :char 32)) 96 | ("/proc/self/mountinfo" "%*d %*d %*d:%*d / %s %*[^-]- %*s /dev/%s" 97 | (fail "Device not found in mountinfo table")) 98 | (when (= 0 (cffi:foreign-funcall "strncmp" :pointer name :string device :size 32 :int)) 99 | (return (pathname-utils:parse-native-namestring 100 | (cffi:foreign-string-to-lisp mount :max-chars 32) 101 | :as :directory))))) 102 | 103 | (cffi:defcstruct (statvfs :size #+64-bit 112 104 | #+32-bit 72 105 | :conc-name statvfs-) 106 | (bsize :unsigned-long) 107 | (frsize :unsigned-long) 108 | (blocks :unsigned-long) 109 | (bfree :unsigned-long) 110 | (bavail :unsigned-long) 111 | (files :unsigned-long) 112 | (ffree :unsigned-long) 113 | (favail :unsigned-long) 114 | (fsid :unsigned-long) 115 | (flag :unsigned-long) 116 | (namemax :unsigned-long)) 117 | 118 | (define-implementation storage-room (path) 119 | (when (stringp path) 120 | (setf path (storage-device-path path))) 121 | (cffi:with-foreign-objects ((statvfs '(:struct statvfs))) 122 | (posix-call "statvfs" :string (pathname-utils:native-namestring path) :pointer statvfs :int) 123 | (values (* (statvfs-bavail statvfs) 124 | (statvfs-bsize statvfs)) 125 | (* (statvfs-blocks statvfs) 126 | (statvfs-bsize statvfs))))) 127 | 128 | (define-implementation storage-io-bytes (device) 129 | (when (pathnamep device) 130 | (setf device (storage-device device))) 131 | ;; device-mapper crap might have the device be a symlink, so resolve it. 132 | (setf device (pathname-name (truename (make-pathname :name device :directory '(:absolute "dev"))))) 133 | (cffi:with-foreign-objects ((lasttop :char 32)) 134 | (setf (cffi:mem-aref lasttop :char 0) 1) 135 | (etypecase device 136 | ((eql T) 137 | (let ((read 0) (write 0)) 138 | (do-proc ((name :char 32) 139 | (reads :unsigned-long-long) 140 | (writes :unsigned-long-long)) 141 | ("/proc/diskstats" "%*d %*d %31s %*u %*u %llu %*u %*u %*u %llu" 142 | (values (* 512 (+ read write)) 143 | (* 512 read) 144 | (* 512 write))) 145 | (when (/= 0 (cffi:foreign-funcall "strncmp" :pointer lasttop :pointer name :size (cffi:foreign-funcall "strlen" :pointer lasttop :size) :int)) 146 | (cffi:foreign-funcall "strncpy" :pointer lasttop :pointer name :size 32) 147 | (incf read reads) 148 | (incf write writes))))) 149 | (string 150 | (do-proc ((name :char 32) 151 | (reads :unsigned-long-long) 152 | (writes :unsigned-long-long)) 153 | ("/proc/diskstats" "%*d %*d %31s %*u %*u %llu %*u %*u %*u %llu" (fail "No such device.")) 154 | (when (= 0 (cffi:foreign-funcall "strncmp" :pointer name :string device :size 32 :int)) 155 | (return (values (* 512 (+ reads writes)) 156 | (* 512 reads) 157 | (* 512 writes))))))))) 158 | 159 | (define-implementation network-devices () 160 | (let ((list ())) 161 | (do-proc ((name :char 32)) 162 | ("/proc/net/dev" "%31s" (cddr (nreverse list))) 163 | (push (cffi:foreign-string-to-lisp name :count (1- (cffi:foreign-funcall "strlen" :pointer name :size))) list)))) 164 | 165 | (define-implementation network-io-bytes (device) 166 | (etypecase device 167 | ((eql T) 168 | (let ((read 0) (write 0)) 169 | (do-proc ((name :char 32) 170 | (reads :unsigned-long-long) 171 | (writes :unsigned-long-long)) 172 | ("/proc/net/dev" "%31s %llu %*u %*u %*u %*u %*u %*u %*u %llu %*u" 173 | (values (+ read write) read write)) 174 | (unless (= 0 (cffi:foreign-funcall "strncmp" :pointer name :string "lo:" :size 32 :int)) 175 | (incf read reads) 176 | (incf write writes))))) 177 | (string 178 | (do-proc ((name :char 32) 179 | (reads :unsigned-long-long) 180 | (writes :unsigned-long-long)) 181 | ("/proc/net/dev" "%31s %llu %*u %*u %*u %*u %*u %*u %*u %llu %*u" 182 | (fail "No such device.")) 183 | (when (= 0 (cffi:foreign-funcall "strncmp" :pointer name :string device :size (min 32 (length device)) :int)) 184 | (return (values (+ reads writes) 185 | reads 186 | writes))))))) 187 | 188 | (define-implementation machine-info () 189 | (flet ((maybe-read-line (file) 190 | (if (probe-file file) 191 | (with-open-file (o file) (read-line o)) 192 | "Unknown"))) 193 | (values (maybe-read-line "/sys/devices/virtual/dmi/id/board_vendor") 194 | (maybe-read-line "/sys/devices/virtual/dmi/id/board_name") 195 | :linux 196 | (do-proc ((version :char 64)) ("/proc/version" "Linux version %s") 197 | (return (cffi:foreign-string-to-lisp version :max-chars 64)))))) 198 | 199 | (defun prefix-p (prefix str) 200 | (and (<= (length prefix) (length str)) 201 | (string= str prefix :end1 (length prefix)))) 202 | 203 | (define-implementation machine-core-info () 204 | (let (vendor model version) 205 | (do-proc ((key :char 32) (value :char 512)) ("/proc/cpuinfo" #.(format NIL "%[^:]: %512[^~a]" #\Linefeed)) 206 | (let ((key (cffi:foreign-string-to-lisp key :max-chars 32))) 207 | (flet ((val () 208 | (cffi:foreign-string-to-lisp value :max-chars 512))) 209 | (cond ((prefix-p "vendor_id" key) (setf vendor (val))) 210 | ((prefix-p "model name" key) (setf model (val))) 211 | ((prefix-p "microcode" key) (setf version (val)))))) 212 | (when (and vendor model version) (return))) 213 | (values (or vendor "Unknown") 214 | (or model "Unknown") 215 | (arch-type) 216 | (or version "Unknown")))) 217 | 218 | (define-implementation self () 219 | (truename "/proc/self/exe")) 220 | 221 | (cffi:defcstruct (sockaddr4 :conc-name sockaddr4-) 222 | (family :ushort) 223 | (port :uint16) 224 | (addr :uint32)) 225 | 226 | (cffi:defcstruct (sockaddr6 :conc-name sockaddr6-) 227 | (family :ushort) 228 | (port :uint16) 229 | (flow-info :uint32) 230 | (addr :uint16 :count 8) 231 | (scope-id :uint32)) 232 | 233 | (cffi:defcstruct (ifaddrs :conc-name ifaddrs-) 234 | (next :pointer) 235 | (name :string) 236 | (flags :uint) 237 | (addr :pointer) 238 | (netmask :pointer) 239 | (bcast :pointer) 240 | (data :pointer)) 241 | 242 | (defun ipv4-str (ipv4) 243 | (format NIL "~d.~d.~d.~d" 244 | (ldb (byte 8 0) ipv4) 245 | (ldb (byte 8 8) ipv4) 246 | (ldb (byte 8 16) ipv4) 247 | (ldb (byte 8 24) ipv4))) 248 | 249 | (defun ipv6-str (ipv6) 250 | (flet ((be->le (i) 251 | (rotatef (ldb (byte 8 0) i) (ldb (byte 8 8) i)) 252 | i)) 253 | (format NIL "~x:~x:~x:~x:~x:~x:~x:~x" 254 | (be->le (cffi:mem-aref ipv6 :uint16 0)) 255 | (be->le (cffi:mem-aref ipv6 :uint16 1)) 256 | (be->le (cffi:mem-aref ipv6 :uint16 2)) 257 | (be->le (cffi:mem-aref ipv6 :uint16 3)) 258 | (be->le (cffi:mem-aref ipv6 :uint16 4)) 259 | (be->le (cffi:mem-aref ipv6 :uint16 5)) 260 | (be->le (cffi:mem-aref ipv6 :uint16 6)) 261 | (be->le (cffi:mem-aref ipv6 :uint16 7))))) 262 | 263 | (define-implementation network-address (device) 264 | (cffi:with-foreign-object (ifaddrs :pointer) 265 | (posix-call "getifaddrs" :pointer ifaddrs :int) 266 | (let ((ifaddrs (cffi:mem-ref ifaddrs :pointer)) ipv4 ipv6) 267 | (unwind-protect 268 | (let ((ifaddrs ifaddrs)) 269 | (loop until (cffi:null-pointer-p ifaddrs) 270 | do (when (string= device (ifaddrs-name ifaddrs)) 271 | (let ((address (ifaddrs-addr ifaddrs))) 272 | (unless (cffi:null-pointer-p address) ;; Address can be NULL for Wireguard for example 273 | (case (sockaddr4-family address) 274 | (2 (setf ipv4 (ipv4-str (sockaddr4-addr address)))) 275 | (10 (setf ipv6 (ipv6-str (sockaddr6-addr address)))))))) 276 | (setf ifaddrs (ifaddrs-next ifaddrs))) 277 | (values (with-open-file (o (format NIL "/sys/class/net/~a/address" device) :if-does-not-exist NIL) 278 | (if o 279 | (let ((addr (read-line o))) 280 | (when (> (length addr) 0) ;; This file can be empty 281 | addr)) 282 | (fail "No such device."))) 283 | ipv4 284 | ipv6)) 285 | (cffi:foreign-funcall "freeifaddrs" :pointer ifaddrs))))) 286 | 287 | (define-implementation machine-battery () 288 | (values (with-open-file (o "/sys/class/power_supply/BAT0/energy_now" :if-does-not-exist NIL) 289 | (if o (float (parse-integer (read-line o)) 0d0) 0d0)) 290 | (with-open-file (o "/sys/class/power_supply/BAT0/energy_full" :if-does-not-exist NIL) 291 | (if o (float (parse-integer (read-line o)) 0d0) 0d0)) 292 | (with-open-file (o "/sys/class/power_supply/BAT0/status" :if-does-not-exist NIL) 293 | (when o (let ((status (read-line o))) 294 | (cond ((string-equal status "charging") :charging) 295 | ((string-equal status "discharging") :discharging) 296 | ((string-equal status "full") :full))))))) 297 | -------------------------------------------------------------------------------- /machine-state.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem machine-state 2 | :version "1.2.0" 3 | :license "zlib" 4 | :author "Yukari Hafner " 5 | :maintainer "Yukari Hafner " 6 | :description "Retrieve machine state information about CPU time, memory usage, etc." 7 | :homepage "https://shinmera.github.io/machine-state/" 8 | :bug-tracker "https://github.com/shinmera/machine-state/issues" 9 | :source-control (:git "https://github.com/shinmera/machine-state.git") 10 | :serial T 11 | :components ((:file "package") 12 | (:file "protocol") 13 | (:file "windows" :if-feature (:or :windows :win32)) 14 | (:file "posix" :if-feature (:and (:not :openbsd) 15 | (:or :posix :linux :darwin :bsd))) 16 | (:file "darwin" :if-feature :darwin) 17 | (:file "bsd" :if-feature (:and :bsd (:not :darwin))) 18 | (:file "freebsd" :if-feature :freebsd) 19 | (:file "openbsd" :if-feature :openbsd) 20 | (:file "linux" :if-feature :linux) 21 | (:file "nx" :if-feature :nx) 22 | (:file "mezzano" :if-feature :mezzano) 23 | (:file "documentation")) 24 | :defsystem-depends-on (:trivial-features) 25 | :depends-on (:documentation-utils 26 | (:feature (:not :mezzano) :cffi) 27 | ;; 32bit SBCL does not support threads on OpenBSD 28 | (:feature (:not (:and :sbcl :openbsd :32-bit)) :bordeaux-threads) 29 | :pathname-utils 30 | (:feature :windows :com-on)) 31 | :in-order-to ((asdf:test-op (asdf:test-op :machine-state/test)))) 32 | 33 | (asdf:defsystem machine-state/opengl 34 | :version "1.0.0" 35 | :license "zlib" 36 | :author "Yukari Hafner " 37 | :maintainer "Yukari Hafner " 38 | :description "Additions for GPU state information using OpenGL" 39 | :components ((:file "opengl")) 40 | :depends-on (:machine-state :cl-opengl)) 41 | 42 | (asdf:defsystem machine-state/test 43 | :version "1.0.0" 44 | :license "zlib" 45 | :author "Yukari Hafner " 46 | :maintainer "Yukari Hafner " 47 | :description "Tests for the machine-state library" 48 | :components ((:file "test")) 49 | :depends-on (:machine-state :parachute) 50 | :perform (asdf:test-op (op c) (uiop:symbol-call :parachute :test :org.shirakumo.machine-state.test))) 51 | -------------------------------------------------------------------------------- /mezzano.lisp: -------------------------------------------------------------------------------- 1 | (in-package :machine-state) 2 | 3 | (define-implementation machine-cores () 4 | (mezzano.supervisor:logical-core-count)) 5 | 6 | (define-implementation machine-room () 7 | (multiple-value-bind (free total) 8 | (mezzano.supervisor:physical-memory-statistics) 9 | (values (* total 4096) (* free 4096)))) 10 | 11 | ;;this is technically incorrect, should I do what mezzano's ROOM does? 12 | ;;ROOM is very slow... 13 | (define-implementation gc-room () (machine-room)) 14 | (define-implementation process-room () (machine-room)) 15 | 16 | (define-implementation gc-time () 17 | mezzano.internals::*gc-time*) 18 | 19 | (define-implementation thread-time (thread) 20 | (let ((the-thread (if (eql thread t) (bt:current-thread) thread))) 21 | (float 22 | (/ (mezzano.supervisor:thread-run-time the-thread) (* 1000 1000)) 23 | 0d0))) 24 | 25 | (define-implementation machine-info () 26 | (values "Unknown" 27 | "Unknown" 28 | :mezzano 29 | (lisp-implementation-version))) 30 | 31 | (define-implementation machine-core-info () 32 | (multiple-value-bind (cpuid-max vendor-1 vendor-3 vendor-2) (mezzano.internals::cpuid 0) 33 | (let (model version) 34 | (when (>= cpuid-max 1) 35 | (multiple-value-bind (a b c d) (mezzano.internals::cpuid 1) 36 | (let ((model (ldb (byte 4 4) a)) 37 | (family-id (ldb (byte 4 8) a)) 38 | (extended-model-id (ldb (byte 4 16) a)) 39 | (extended-family-id (ldb (byte 8 20) a))) 40 | (setf model (format NIL "~X ~X" 41 | (if (or (= family-id #x6) (= family-id #xF)) 42 | (+ (ash extended-model-id 4) model) 43 | model) 44 | (if (= family-id #xF) 45 | (+ family-id extended-family-id) 46 | family-id)))))) 47 | (values (mezzano.internals::decode-cpuid-vendor vendor-1 vendor-2 vendor-3) 48 | (or model "Unknown") 49 | (arch-type) 50 | (or version "Unknown"))))) 51 | 52 | (define-implementation machine-uptime () 53 | (truncate (get-internal-run-time) INTERNAL-TIME-UNITS-PER-SECOND)) 54 | 55 | ;; (define-implementation storage-device (path) 56 | ;; (fail)) 57 | 58 | ;; (define-implementation storage-device-path (device) 59 | ;; (fail)) 60 | 61 | ;; (define-implementation storage-room (device) 62 | ;; (fail)) 63 | 64 | (define-implementation network-devices () 65 | (mapcar #'princ-to-string (mezzano.sync:watchable-set-items mezzano.driver.network-card::*nics*))) 66 | 67 | (defun network-card (device) 68 | (or (find device (mezzano.sync:watchable-set-items mezzano.driver.network-card::*nics*) 69 | :key #'princ-to-string 70 | :test #'equal) 71 | (error "No such device."))) 72 | 73 | (define-implementation network-io-bytes (device) 74 | (etypecase device 75 | ((eql T) 76 | (let ((read 0) (write 0)) 77 | (dolist (card (mezzano.sync:watchable-set-items mezzano.driver.network-card::*nics*)) 78 | (multiple-value-bind (rx-bytes rx-packets rx-errors tx-bytes tx-packets tx-errors collisions) 79 | (mezzano.driver.network-card:statistics card) 80 | (declare (ignore rx-packets rx-errors tx-packets tx-errors collisions)) 81 | (incf read rx-bytes) 82 | (incf write tx-bytes))) 83 | (values (+ read write) read write))) 84 | (string 85 | (multiple-value-bind (rx-bytes rx-packets rx-errors tx-bytes tx-packets tx-errors collisions) 86 | (mezzano.driver.network-card:statistics (network-card device)) 87 | (declare (ignore rx-packets rx-errors tx-packets tx-errors collisions)) 88 | (values (+ rx-bytes tx-bytes) rx-bytes tx-bytes))))) 89 | 90 | (define-implementation network-info () 91 | (values (machine-instance))) 92 | 93 | (define-implementation network-address (device) 94 | (let ((card (network-card device))) 95 | (values (format NIL "~/mezzano.network.ethernet:format-mac-address/" 96 | (mezzano.driver.network-card:mac-address card)) 97 | (mezzano.network.ip:ipv4-interface-address card nil) 98 | NIL))) 99 | -------------------------------------------------------------------------------- /nx.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.machine-state) 2 | 3 | (defmacro nxgl-call (func &rest args) 4 | `(when (= 0 (cffi:foreign-funcall ,func ,@args :int)) 5 | (fail))) 6 | 7 | (define-implementation process-room () 8 | (cffi:with-foreign-objects ((free :size) (total :size)) 9 | (nxgl-call "nxgl_ram" :pointer free :pointer total) 10 | (- (cffi:mem-ref total :size) (cffi:mem-ref free :size)))) 11 | 12 | (define-implementation machine-room () 13 | (cffi:with-foreign-objects ((free :size) (total :size)) 14 | (nxgl-call "nxgl_ram" :pointer free :pointer total) 15 | (values (- (cffi:mem-ref total :size) (cffi:mem-ref free :size)) 16 | (cffi:mem-ref total :size)))) 17 | 18 | (define-implementation machine-cores () 19 | (cffi:foreign-funcall "nxgl_core_count" :int)) 20 | 21 | (defmacro with-thread-handle ((handle thread &optional (default 0)) &body body) 22 | `(if (or (eql ,thread T) 23 | (eql ,thread (bt:current-thread))) 24 | (let ((,handle (cffi:null-pointer))) 25 | ,@body) 26 | ,default)) 27 | 28 | (define-implementation thread-core-mask (thread) 29 | (with-thread-handle (handle thread (1- (ash 1 (machine-cores)))) 30 | (cffi:with-foreign-objects ((mask :uint64)) 31 | (nxgl-call "nxgl_get_core_mask" :pointer handle :pointer mask) 32 | (cffi:mem-ref mask :uint64)))) 33 | 34 | (define-implementation (setf thread-core-mask) (mask-int thread) 35 | (with-thread-handle (handle thread (1- (ash 1 (machine-cores)))) 36 | (cffi:with-foreign-objects ((mask :uint64)) 37 | (setf (cffi:mem-ref mask :uint64) mask-int) 38 | (nxgl-call "nxgl_set_core_mask" :pointer handle :pointer mask) 39 | (cffi:mem-ref mask :uint64)))) 40 | 41 | (define-implementation gpu-room () 42 | (cffi:with-foreign-objects ((free :size) (total :size)) 43 | (nxgl-call "nxgl_vram" :pointer free :pointer total) 44 | (values (cffi:mem-ref free :size) 45 | (cffi:mem-ref total :size)))) 46 | 47 | (define-implementation process-info () 48 | (values (make-pathname :name "sbcl" :device "rom" :directory '(:absolute)) 49 | (make-pathname :device "tmp" :directory '(:absolute)) 50 | (cffi:with-foreign-object (nick :char 33) 51 | (when (cffi:foreign-funcall "nxgl_username" :pointer nick :int 33 :bool) 52 | (cffi:foreign-string-to-lisp nick :max-chars 33))) 53 | "Unknown")) 54 | 55 | (define-implementation network-devices () 56 | (list "net")) 57 | 58 | (defun mac-str (octets) 59 | (format NIL "~{~2,'0x~^:~}" (coerce octets 'list))) 60 | 61 | (defun ipv4-str (ipv4) 62 | (format NIL "~d.~d.~d.~d" 63 | (ldb (byte 8 0) ipv4) 64 | (ldb (byte 8 8) ipv4) 65 | (ldb (byte 8 16) ipv4) 66 | (ldb (byte 8 24) ipv4))) 67 | 68 | (define-implementation network-address (device) 69 | (values (cffi:with-foreign-object (mac :uint8 6) 70 | (when (cffi:foreign-funcall "nxgl_mac_address" :pointer mac :bool) 71 | (mac-str (cffi:foreign-array-to-lisp mac '(:array :uint8 6))))) 72 | (cffi:with-foreign-object (addr :uint32) 73 | (when (cffi:foreign-funcall "nxgl_ip_address" :pointer addr :bool) 74 | (ipv4-str (cffi:mem-ref addr :uint32)))) 75 | NIL)) 76 | -------------------------------------------------------------------------------- /openbsd.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.machine-state) 2 | 3 | ;;;; https://github.com/openbsd/src/blob/master/sys/sys/sysctl.h#L103 4 | (defconstant +ctl-kern+ 1) 5 | (defconstant +kern-proc-pid+ 1) 6 | (defconstant +kern-osrelease+ 2) 7 | (defconstant +kern-hostname+ 10) 8 | (defconstant +kern-clockrate+ 12) 9 | (defconstant +kern-boottime+ 21) 10 | (defconstant +kern-cptime+ 40) 11 | (defconstant +kern-proc+ 66) 12 | (defconstant +kern-cptime2+ 71) 13 | (defconstant +kern-proc-cwd+ 78) 14 | (defconstant +kern-cpustats+ 85) 15 | (defconstant +kern-proc-show-threads+ #x40000000) 16 | 17 | ;;;; https://github.com/openbsd/src/blob/master/sys/sys/sysctl.h#L919 18 | (defconstant +ctl-hw+ 6) 19 | (defconstant +hw-machine+ 1) 20 | (defconstant +hw-model+ 2) 21 | (defconstant +hw-diskstats+ 9) 22 | (defconstant +hw-diskcount+ 10) 23 | (defconstant +hw-sensors+ 11) 24 | (defconstant +hw-vendor+ 14) 25 | (defconstant +hw-product+ 15) 26 | (defconstant +hw-physmem64+ 19) 27 | (defconstant +hw-ncpuonline+ 25) 28 | 29 | ;;;; https://github.com/openbsd/src/blob/master/sys/uvm/uvmexp.h#L7 30 | (defconstant +ctl-vm+ 2) 31 | (defconstant +vm-uvmexp+ 4) 32 | 33 | ;;;; https://github.com/openbsd/src/blob/master/sys/sys/sysctl.h#L370 34 | (cffi:defcstruct (kinfo-proc :size 644 :conc-name kinfo-proc-) 35 | (user-id :uint32 :offset 128) ;; p_uid 36 | (group-id :uint32 :offset 136) ;; p_gid 37 | (nice :uint8 :offset 307) ;; p_nice 38 | (command-name (:array :char #.+maxcomlen+) :offset 312) ;; p_comm 39 | (resident-set-size :int32 :offset 384) ;; p_vm_rssize 40 | (user-time-seconds :uint32 :offset 420) ;; p_uutime_sec 41 | (user-time-microseconds :uint32 :offset 424) ;; p_uutime_usec 42 | (thread-id :int32 :offset 608) ;; p_tid 43 | (thread-name (:array :char #.+maxcomlen+) :offset 624)) ;; p_name 44 | 45 | (defmacro with-current-process ((proc) &body body) 46 | (let ((size (cffi:foreign-type-size '(:struct kinfo-proc)))) 47 | `(with-sysctl ((+ctl-kern+ +kern-proc+ +kern-proc-pid+ (getpid) ,size 1) ,proc '(:struct kinfo-proc)) 48 | ,@body))) 49 | 50 | (define-implementation process-room () 51 | (with-current-process (proc) 52 | (* (page-size) (kinfo-proc-resident-set-size proc)))) 53 | 54 | ;;;; These functions are shared between the processes and threads impls 55 | ;;;; User time only, will differ from output of PS or TOP 56 | (defun %process-time (kinfo-proc) 57 | (+ (kinfo-proc-user-time-seconds kinfo-proc) 58 | (/ (kinfo-proc-user-time-microseconds kinfo-proc) 1000000.0d0))) 59 | 60 | (define-implementation process-time () 61 | (with-current-process (proc) 62 | (%process-time proc))) 63 | 64 | (define-implementation process-priority () 65 | (with-current-process (proc) 66 | (let ((value (- (kinfo-proc-nice proc) 20))) ;; Will return between 0 (-20) and 40 (20) 67 | (process-nice->priority value)))) 68 | 69 | (define-implementation (setf process-priority) (priority) 70 | (let ((prio (priority->process-nice priority))) 71 | (posix-call "setpriority" :int 0 :uint32 (getpid) :int prio :int)) 72 | (process-priority)) ;; Get the actual priority 73 | 74 | #+thread-support 75 | (progn 76 | (defmacro with-threads ((thread &optional pid) &body body) 77 | (with-gensyms (mib %pid i nproc procs size) 78 | ;; Call sysctl once to find how many bytes will be returned 79 | `(let* ((,%pid (or ,pid (getpid))) 80 | (,size (cffi:foreign-type-size '(:struct kinfo-proc))) 81 | (,mib (sysctl-resolve-mib 82 | (list +ctl-kern+ +kern-proc+ (logior +kern-proc-pid+ +kern-proc-show-threads+) ,%pid ,size 0))) 83 | (,nproc (ceiling (/ (sysctl-size ,mib) ,size)))) 84 | 85 | (rplaca (last ,mib) ,nproc) 86 | 87 | (with-sysctl (,mib ,procs '(:struct kinfo-proc) ,nproc) 88 | (dotimes (,i ,nproc) 89 | (let ((,thread (cffi:mem-aptr ,procs '(:struct kinfo-proc) ,i))) 90 | (when (> (kinfo-proc-thread-id ,thread) 1) 91 | ,@body))))))) 92 | 93 | (defmacro with-current-thread ((thread) &body body) 94 | (with-gensyms (tid) 95 | `(let ((,tid (cffi:foreign-funcall "getthrid" :long))) 96 | (with-threads (,thread) 97 | (when (= ,tid (kinfo-proc-thread-id ,thread)) 98 | (return ,@body)))))) 99 | 100 | (defmacro with-current-thread-handle ((handle thread &optional (default 0)) &body body) 101 | (with-gensyms (%thread) 102 | `(let ((,%thread ,thread)) 103 | (if (or (eql ,%thread T) 104 | (eql ,%thread (bt:current-thread))) 105 | (with-current-thread (,handle) 106 | ,@body) 107 | ,default)))) 108 | (define-implementation thread-time (thread) 109 | (with-current-thread-handle (handle thread 0.0d0) 110 | (%process-time handle)))) 111 | 112 | ;;;; process-io-bytes, thread-priority and thread-core-mask are unsupported 113 | ;;;; Reference: https://github.com/openbsd/src/blob/master/include/unistd.h#L100 114 | 115 | (defun split-path (path &optional (delimiter #\:)) 116 | (let (paths start) 117 | (do ((i 0 (1+ i))) 118 | ((= i (length path)) (nreverse paths)) 119 | (when (char= (schar path i) delimiter) 120 | (push (subseq path (or start 0) i) paths) 121 | (setf start (1+ i)))))) 122 | 123 | (define-implementation process-info () 124 | (with-current-process (proc) 125 | (values (let ((command (cffi:foreign-string-to-lisp 126 | (cffi:foreign-slot-pointer proc '(:struct kinfo-proc) 'command-name)))) 127 | (or (resolve-executable command) command)) 128 | (pathname-utils:parse-native-namestring (sysctl-string (list +ctl-kern+ +kern-proc-cwd+ (getpid)) 1024) :as :directory) 129 | (uid->user (kinfo-proc-user-id proc)) 130 | (gid->group (kinfo-proc-group-id proc))))) 131 | 132 | (cffi:defcstruct (uvmexp :size 344 :conc-name uvmexp-) 133 | (pagesize :int :offset 0) 134 | (npages :int :offset 12) 135 | (free :int :offset 16) 136 | (inactive :int :offset 24)) 137 | 138 | (define-implementation machine-room () 139 | (with-sysctl ((+ctl-vm+ +vm-uvmexp+) uvm '(:struct uvmexp)) 140 | (flet ((pages->bytes (n) 141 | (* n (uvmexp-pagesize uvm)))) 142 | (let* ((total-pages (uvmexp-npages uvm)) 143 | (free-pages (+ (uvmexp-free uvm) (uvmexp-inactive uvm))) 144 | (total-bytes (pages->bytes total-pages)) 145 | (free-bytes (pages->bytes free-pages))) 146 | (values (- total-bytes free-bytes) 147 | total-bytes))))) 148 | 149 | (define-implementation machine-uptime () 150 | (with-sysctl ((+ctl-kern+ +kern-boottime+) tv '(:struct timeval)) 151 | (- (get-unix-time) (timeval-sec tv)))) 152 | 153 | (define-implementation machine-cores () 154 | (sysctl-ref (list +ctl-hw+ +hw-ncpuonline+) :int)) 155 | 156 | (defconstant +cpustates+ 6) 157 | 158 | (cffi:defcstruct (cpustats :size 56 :conc-name cpustats-) 159 | (times (:array :uint64 #.+cpustates+))) ;; cs_time 160 | 161 | (defun core-time (core) 162 | (with-sysctl ((+ctl-kern+ +kern-cpustats+ core) cpustats '(:struct cpustats)) 163 | (cpustats-times cpustats))) 164 | 165 | (defun cpu-time () 166 | (sysctl-ref (list +ctl-kern+ +kern-cptime+) `(:array :long ,+cpustates+))) 167 | 168 | ;;;; KERN_CPTIME2 returns wrong values for some reason, KERN_CPUSTATS works better 169 | (define-implementation machine-time (core) 170 | (with-sysctl ((+ctl-kern+ +kern-clockrate+) clockinfo '(:struct clockinfo)) 171 | (flet ((conv (x) (/ x (float (clockinfo-hz clockinfo) 0.0d0)))) 172 | (let ((values (cond 173 | ((eq 't core) (cpu-time)) 174 | ((>= core (machine-cores)) (fail "No such core.")) 175 | (t (core-time core))))) 176 | (destructuring-bind (user nice sys spin intr idle) (coerce values 'list) 177 | (values (conv idle) 178 | (conv (+ user nice sys spin intr idle)))))))) 179 | 180 | ;;;; Reference: 181 | ;;;; https://github.com/openbsd/src/blob/master/sys/sys/sensors.h 182 | ;;;; https://github.com/openbsd/src/blob/master/sbin/sysctl/sysctl.c#L2554 183 | 184 | (defconstant +sensor-type-volts-dc+ 2) 185 | (defconstant +sensor-type-amphour+ 8) 186 | (defconstant +sensor-type-integer+ 10) 187 | 188 | (cffi:defcstruct (sensor :size 68 :conc-name sensor-) 189 | (value :int64 :offset 44)) 190 | 191 | (defconstant +sensor-name-size+ 16) 192 | (cffi:defcstruct (sensordev :size 116 :conc-name sensordev-) 193 | (name (:array :char #.+sensor-name-size+) :offset 4)) ;; xname 194 | 195 | (defconstant +enoent+ 2) 196 | (defconstant +enxio+ 6) 197 | 198 | (defun find-sensor-number (name &optional (dev 0)) 199 | (cffi:with-foreign-object (sensordev '(:struct sensordev)) 200 | (multiple-value-bind (sensordev ret) 201 | (sysctl-unchecked (list +ctl-hw+ +hw-sensors+ dev) sensordev (cffi:foreign-type-size '(:struct sensordev))) 202 | (print ret) 203 | (when (= -1 ret) 204 | (return-from find-sensor-number 205 | (if (= +enxio+ (errno)) 206 | (find-sensor-number name (1+ dev)) 207 | nil))) 208 | (let ((sensor-name (cffi:foreign-slot-pointer sensordev '(:struct sensordev) 'name))) 209 | (if (strncmp-lisp sensor-name name :max-chars +sensor-name-size+) 210 | dev 211 | (find-sensor-number name (1+ dev))))))) 212 | 213 | (defun find-sensor-value (device sensor-type sensor-index) 214 | (with-sysctl ((+ctl-hw+ +hw-sensors+ device sensor-type sensor-index) sensor '(:struct sensor)) 215 | (sensor-value sensor))) 216 | 217 | (define-implementation machine-battery () 218 | (let ((battery-n (find-sensor-number "acpibat0"))) 219 | (if battery-n 220 | (let ((last-full-capacity (find-sensor-value battery-n +sensor-type-amphour+ 0)) 221 | (remaining-capacity (find-sensor-value battery-n +sensor-type-amphour+ 3)) 222 | (state (find-sensor-value battery-n +sensor-type-integer+ 0))) 223 | (values (float remaining-capacity 0.0d0) 224 | (float last-full-capacity 0.0d0) 225 | (case state 226 | (0 :full) 227 | (1 :discharging) 228 | (2 :charging)))) 229 | (values 0.0d0 0.0d0 nil)))) 230 | 231 | (define-implementation machine-info () 232 | (values 233 | (sysctl-string (list +ctl-hw+ +hw-vendor+) 128) 234 | (sysctl-string (list +ctl-hw+ +hw-product+) 128) 235 | :openbsd 236 | (sysctl-string (list +ctl-kern+ +kern-osrelease+) 16))) 237 | 238 | (define-implementation machine-core-info () 239 | (let ((processor (sysctl-string (list +ctl-hw+ +hw-model+) 128))) 240 | (values processor 241 | processor ;; There doesn't seem to be a separation between those 242 | (arch-type) 243 | (sysctl-string (list +ctl-hw+ +hw-machine+) 32)))) 244 | 245 | (defconstant +mfsnamelen+ 16) 246 | (defconstant +mnamelen+ 90) 247 | 248 | #+32-bit 249 | (cffi:defcstruct (statfs :size 564 :conc-name statfs-) 250 | (block-size :uint32 :offset 4) 251 | (blocks :uint64 :offset 12) 252 | (available-blocks :int64 :offset 28) ;; Blocks available to non-superuser 253 | (synchronous-writes :uint64 :offset 60) 254 | (synchronous-reads :uint64 :offset 68) 255 | (asynchronous-writes :uint64 :offset 76) 256 | (asynchronous-reads :uint64 :offset 84) 257 | (mountpoint (:array :char #.+mnamelen+) :offset 132) 258 | (device (:array :char #.+mnamelen+) :offset 222)) 259 | 260 | #+64-bit 261 | (cffi:defcstruct (statfs :size 568 :conc-name statfs-) 262 | (block-size :uint32 :offset 4) 263 | (blocks :uint64 :offset 16) 264 | (available-blocks :int64 :offset 32) ;; Blocks available to non-superuser 265 | (synchronous-writes :uint64 :offset 64) 266 | (synchronous-reads :uint64 :offset 72) 267 | (asynchronous-writes :uint64 :offset 80) 268 | (asynchronous-reads :uint64 :offset 88) 269 | (mountpoint (:array :char #.+mnamelen+) :offset 136) 270 | (device (:array :char #.+mnamelen+) :offset 226)) 271 | 272 | (define-implementation storage-device (path) 273 | (let ((mount-root (pathname-utils:native-namestring (pathname-force-file (find-mount-root path))))) 274 | (do-filesystems (fs) 275 | (let ((fs-mountpoint (cffi:foreign-slot-pointer fs '(:struct statfs) 'mountpoint))) 276 | (when (strncmp-lisp fs-mountpoint mount-root :max-chars +mnamelen+) 277 | (return (pathname-name 278 | (cffi:foreign-string-to-lisp 279 | (cffi:foreign-slot-pointer fs '(:struct statfs) 'device) :max-chars +mnamelen+)))))))) 280 | 281 | (define-implementation storage-device-path (device) 282 | (let ((device-path (pathname-utils:native-namestring (make-pathname :defaults #P"/dev/" :name device)))) 283 | (do-filesystems (fs) 284 | (let ((fs-device (cffi:foreign-slot-pointer fs '(:struct statfs) 'device))) 285 | (when (strncmp-lisp fs-device device-path :max-chars +mnamelen+) 286 | (return (pathname-utils:parse-native-namestring 287 | (cffi:foreign-string-to-lisp 288 | (cffi:foreign-slot-pointer fs '(:struct statfs) 'mountpoint) :max-chars +mnamelen+)))))))) 289 | 290 | (define-implementation storage-io-bytes (path) 291 | (setf path (pathname-utils:native-namestring 292 | (pathname-force-file 293 | (etypecase path 294 | (pathname (find-mount-root path)) 295 | (string (storage-device-path path)))))) 296 | 297 | (do-filesystems (fs) 298 | (let ((fs-mountpoint (cffi:foreign-slot-pointer fs '(:struct statfs) 'mountpoint))) 299 | (when (strncmp-lisp fs-mountpoint path :max-chars +mnamelen+) 300 | (let ((reads (+ (statfs-synchronous-reads fs) 301 | (statfs-asynchronous-reads fs))) 302 | (writes (+ (statfs-synchronous-writes fs) 303 | (statfs-asynchronous-writes fs)))) 304 | (return-from storage-io-bytes 305 | (values (+ reads writes) reads writes))))))) 306 | 307 | (define-implementation storage-room (path) 308 | (when (stringp path) 309 | (setf path (storage-device-path path))) 310 | 311 | (let ((mount-root (pathname-utils:native-namestring (pathname-force-file (find-mount-root path))))) 312 | (do-filesystems (fs) 313 | (let ((fs-mountpoint (cffi:foreign-slot-pointer fs '(:struct statfs) 'mountpoint))) 314 | (when (strncmp-lisp fs-mountpoint mount-root :max-chars +mnamelen+) 315 | (flet ((block->bytes (n) 316 | (* n (statfs-block-size fs)))) 317 | (return-from storage-room 318 | (values (block->bytes (statfs-available-blocks fs)) 319 | (block->bytes (statfs-blocks fs)))))))))) 320 | 321 | (define-implementation network-info () 322 | (sysctl-string (list +ctl-kern+ +kern-hostname+) 255)) 323 | 324 | ;;;; network-io-bytes is unsupported 325 | ;;;; `struct ifaddrs' has a `void* ifa_data' field which should be an `if_data' struct 326 | ;;;; but this is NULL on OpenBSD, see the FreeBSD code for how it should work 327 | -------------------------------------------------------------------------------- /opengl.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.machine-state) 2 | 3 | (defun gl-vendor () 4 | (let ((vendor (gl:get-string :vendor))) 5 | (cond ((search "Intel" vendor) :intel) 6 | ((search "NVIDIA" vendor) :nvidia) 7 | ((search "ATI" vendor) :amd) 8 | ((search "AMD" vendor) :amd) 9 | (T :unknown)))) 10 | 11 | (declaim (notinline gpu-room)) 12 | (define-implementation gpu-room () 13 | (macrolet ((jit (thing) 14 | `(multiple-value-prog1 ,thing 15 | (compile 'gpu-room '(lambda () ,thing))))) 16 | (case (gl-vendor) 17 | ;; https://www.khronos.org/registry/OpenGL/extensions/ATI/ATI_meminfo.txt 18 | (:amd 19 | (jit (let* ((vbo-free-memory-ati (gl:get-integer #x87FB 4)) 20 | (tex-free-memory-ati (gl:get-integer #x87FC 4)) 21 | (buf-free-memory-ati (gl:get-integer #x87FD 4)) 22 | (total (+ (aref vbo-free-memory-ati 0) 23 | (aref tex-free-memory-ati 0) 24 | (aref buf-free-memory-ati 0)))) 25 | (values (* 1024 total) (* 1024 total))))) 26 | ;; http://developer.download.nvidia.com/opengl/specs/GL_NVX_gpu_memory_info.txt 27 | (:nvidia 28 | (jit (let ((vidmem-total (gl:get-integer #x9047 1)) 29 | (vidmem-free (gl:get-integer #x9049 1))) 30 | (values (* 1024 vidmem-free) 31 | (* 1024 vidmem-total))))) 32 | (:intel 33 | (jit (gc-room))) 34 | (T (jit (values 0 0)))))) 35 | 36 | (let ((+gpu-time-query-object+ NIL) 37 | (+gpu-time+ 0)) 38 | (define-implementation gpu-time () 39 | (cond (+gpu-time-query-object+ 40 | (handler-case 41 | (progn 42 | (gl:end-query :time-elapsed) 43 | (incf +gpu-time+ (gl:get-query-object +gpu-time-query-object+ :query-result))) 44 | (gl:opengl-error () 45 | (setf +gpu-time-query-object+ (first (gl:gen-queries 1)))))) 46 | (T 47 | (setf +gpu-time-query-object+ (first (gl:gen-queries 1))))) 48 | (gl:begin-query :time-elapsed +gpu-time-query-object+) 49 | (* (float +gpu-time+ 0d0) 1e-9))) 50 | 51 | (define-implementation gpu-info () 52 | (values (let ((vendor (gl:get-string :vendor))) 53 | (cond ((search "intel" vendor :test #'char-equal) :intel) 54 | ((search "nvidia" vendor :test #'char-equal) :nvidia) 55 | ((search "ati" vendor :test #'char-equal) :amd) 56 | ((search "amd" vendor :test #'char-equal) :amd))) 57 | (gl:get-string :renderer) 58 | (gl:get-string :version))) 59 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:org.shirakumo.machine-state 2 | (:use #:cl) 3 | #+windows 4 | (:local-nicknames (#:com #:org.shirakumo.com-on)) 5 | (:export 6 | #:query-failed 7 | #:process-io-bytes 8 | #:process-room 9 | #:process-time 10 | #:machine-room 11 | #:machine-cores 12 | #:machine-uptime 13 | #:machine-time 14 | #:thread-time 15 | #:thread-core-mask 16 | #:process-priority 17 | #:thread-priority 18 | #:gc-room 19 | #:gc-time 20 | #:gpu-room 21 | #:gpu-time 22 | #:static-room 23 | #:stack-room 24 | #:storage-device 25 | #:storage-device-path 26 | #:storage-room 27 | #:storage-io-bytes 28 | #:network-devices 29 | #:network-io-bytes 30 | #:machine-info 31 | #:machine-battery 32 | #:machine-core-info 33 | #:process-info 34 | #:gpu-info 35 | #:network-info 36 | #:network-address)) 37 | -------------------------------------------------------------------------------- /posix.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.machine-state) 2 | 3 | (cffi:defcvar (errno "errno") :int64) 4 | 5 | (defun strerror () 6 | (cffi:foreign-funcall "strerror" :int64 errno :string)) 7 | 8 | (defmacro posix-call (function &rest args) 9 | `(let ((val (cffi:foreign-funcall ,function ,@args))) 10 | (if (< val 0) 11 | (fail (strerror)) 12 | val))) 13 | 14 | (defmacro posix-call0 (function &rest args) 15 | `(let ((val (cffi:foreign-funcall ,function ,@args))) 16 | (if (/= 0 val) 17 | (fail (strerror)) 18 | val))) 19 | 20 | (cffi:defcstruct (timeval :conc-name timeval-) 21 | (sec :uint64) 22 | (usec :uint64)) 23 | 24 | (cffi:defcstruct (rusage :conc-name rusage-) 25 | (utime (:struct timeval)) 26 | (stime (:struct timeval)) 27 | ;; Linux fields 28 | (maxrss :long) 29 | (ixrss :long) 30 | (idrss :long) 31 | (isrss :long) 32 | (minflt :long) 33 | (majflt :long) 34 | (nswap :long) 35 | (inblock :long) 36 | (oublock :long) 37 | (msgsnd :long) 38 | (msgrcv :long) 39 | (nsignals :long) 40 | (nvcsw :long) 41 | (nivcsw :long)) 42 | 43 | (define-implementation process-room () 44 | (cffi:with-foreign-object (rusage '(:struct rusage)) 45 | (posix-call "getrusage" :int 0 :pointer rusage :int) 46 | (* 1024 (+ (rusage-ixrss rusage) 47 | (rusage-idrss rusage) 48 | (rusage-isrss rusage))))) 49 | 50 | (define-implementation process-time () 51 | (cffi:with-foreign-object (rusage '(:struct rusage)) 52 | (posix-call "getrusage" :int 0 :pointer rusage :int) 53 | (+ (timeval-sec rusage) 54 | (* (timeval-usec rusage) 10d-7)))) 55 | 56 | (cffi:defcstruct (sysinfo :conc-name sysinfo-) 57 | (uptime :long) 58 | (loads :ulong :count 3) 59 | (total-ram :ulong) 60 | (free-ram :ulong) 61 | (shared-ram :ulong) 62 | (buffer-ram :ulong) 63 | (total-swap :ulong) 64 | (free-swap :ulong) 65 | (processes :ushort) 66 | (total-high :ulong) 67 | (free-high :ulong) 68 | (memory-unit :uint) 69 | (_pad :char :count 22)) 70 | 71 | #-darwin 72 | (define-implementation machine-room () 73 | (cffi:with-foreign-objects ((sysinfo '(:struct sysinfo))) 74 | (posix-call "sysinfo" :pointer sysinfo :int) 75 | (let* ((unit (sysinfo-memory-unit sysinfo)) 76 | (total (* unit (sysinfo-total-ram sysinfo))) 77 | (free (* unit (sysinfo-free-ram sysinfo)))) 78 | (values (- total free) total)))) 79 | 80 | #-darwin 81 | (define-implementation machine-uptime () 82 | (cffi:with-foreign-objects ((sysinfo '(:struct sysinfo))) 83 | (posix-call "sysinfo" :pointer sysinfo :int) 84 | (sysinfo-uptime sysinfo))) 85 | 86 | #-darwin 87 | (define-implementation machine-cores () 88 | ;; _SC_NPROCESSORS_ONLN 84 89 | (posix-call "sysconf" :int 84 :long)) 90 | 91 | (define-implementation process-priority () 92 | (let ((err errno) 93 | (value (cffi:foreign-funcall "getpriority" :int 0 :uint32 0 :int))) 94 | (when (and (= -1 value) (/= err errno)) 95 | (fail (cffi:foreign-funcall "strerror" :int64 errno))) 96 | (cond ((< value -8) :realtime) 97 | ((< value 0) :high) 98 | ((= value 0) :normal) 99 | ((< value +8) :low) 100 | (T :idle)))) 101 | 102 | (define-implementation (setf process-priority) (priority) 103 | (let ((prio (ecase priority 104 | (:idle 19) 105 | (:low 5) 106 | (:normal 0) 107 | (:high -5) 108 | (:realtime -20)))) 109 | (posix-call0 "setpriority" :int 0 :uint32 0 :int prio :int)) 110 | priority) 111 | 112 | #+thread-support 113 | (progn 114 | (defmacro with-thread-handle ((handle thread &optional (default 0)) &body body) 115 | `(if (or (eql ,thread T) 116 | (eql ,thread (bt:current-thread))) 117 | (let ((,handle (cffi:foreign-funcall "pthread_self" :pointer))) 118 | (declare (ignorable ,handle)) 119 | ,@body) 120 | ,default)) 121 | 122 | (define-implementation thread-time (thread) 123 | (with-thread-handle (handle thread 0d0) 124 | (cffi:with-foreign-object (rusage '(:struct rusage)) 125 | (posix-call "getrusage" :int 1 :pointer rusage :int) 126 | (+ (timeval-sec rusage) 127 | (* (timeval-usec rusage) 10d-7))))) 128 | 129 | (define-implementation thread-core-mask (thread) 130 | (with-thread-handle (handle thread (1- (ash 1 (machine-cores)))) 131 | (cffi:with-foreign-objects ((cpuset :uint64)) 132 | (posix-call0 "pthread_getaffinity_np" :pointer handle :size (cffi:foreign-type-size :uint64) :pointer cpuset :int) 133 | (cffi:mem-ref cpuset :uint64)))) 134 | 135 | (define-implementation (setf thread-core-mask) (mask thread) 136 | (with-thread-handle (handle thread (1- (ash 1 (machine-cores)))) 137 | (cffi:with-foreign-objects ((cpuset :uint64)) 138 | (setf (cffi:mem-ref cpuset :uint64) mask) 139 | (posix-call0 "pthread_setaffinity_np" :pointer handle :size (cffi:foreign-type-size :uint64) :pointer cpuset :int) 140 | (cffi:mem-ref cpuset :uint64)))) 141 | 142 | (define-implementation thread-priority (thread) 143 | (with-thread-handle (handle thread :normal) 144 | (cffi:with-foreign-objects ((policy :int) 145 | (param :int)) 146 | (posix-call0 "pthread_getschedparam" :pointer handle :pointer policy :pointer param :int) 147 | (let ((priority (cffi:mem-ref param :int))) 148 | (cond ((< priority 20) :idle) 149 | ((< priority 50) :low) 150 | ((= priority 50) :normal) 151 | ((< priority 70) :high) 152 | (T :realtime)))))) 153 | 154 | (define-implementation (setf thread-priority) (thread priority) 155 | (with-thread-handle (handle thread :normal) 156 | (cffi:with-foreign-objects ((policy :int) 157 | (param :int)) 158 | (posix-call0 "pthread_getschedparam" :pointer handle :pointer policy :pointer param :int) 159 | (let ((policy (cffi:mem-ref policy :int))) 160 | (setf (cffi:mem-ref param :int) (ecase priority 161 | (:idle 1) 162 | (:low 40) 163 | (:normal 50) 164 | (:high 60) 165 | (:realtime 99))) 166 | (posix-call0 "pthread_setschedparam" :pointer handle :int policy :pointer param :int))) 167 | priority))) 168 | 169 | (define-implementation network-info () 170 | (cffi:with-foreign-object (hostname :char 512) 171 | (posix-call "gethostname" :pointer hostname :size 512 :int) 172 | (cffi:foreign-string-to-lisp hostname :max-chars 512))) 173 | 174 | (define-protocol-fun self () (pathname) 175 | *default-pathname-defaults*) 176 | 177 | (define-implementation process-info () 178 | (values 179 | (self) 180 | (pathname-utils:parse-native-namestring 181 | (cffi:with-foreign-object (path :char 1024) 182 | (cffi:foreign-funcall "getcwd" :pointer path :size 1024) 183 | (cffi:foreign-string-to-lisp path :max-chars 1024)) 184 | :as :directory) 185 | (cffi:foreign-funcall "getlogin" :string) 186 | (let ((gid (cffi:foreign-funcall "getpwuid" :size (cffi:foreign-funcall "getgid" :size) :pointer))) 187 | (if (cffi:null-pointer-p gid) 188 | "Unknown" 189 | (cffi:mem-ref gid :string))))) 190 | -------------------------------------------------------------------------------- /protocol.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.machine-state) 2 | 3 | (define-condition query-failed (error) 4 | ((function :initarg :function :initform NIL) 5 | (message :initarg :message :initform NIL)) 6 | (:report (lambda (c s) (format s "The machine state query~@[ for ~a~] failed~@[:~%~% ~a~]" 7 | (slot-value c 'function) (slot-value c 'message))))) 8 | 9 | (defun fail (&optional message function) 10 | (error 'query-failed :function function :message message)) 11 | 12 | (defmacro define-protocol-fun (name args vals &body default) 13 | `(progn 14 | (declaim (ftype (function ,(mapcar #'second args) (values ,@vals &optional)) ,name)) 15 | (declaim (inline ,name)) 16 | (setf (fdefinition ',name) 17 | (lambda ,(mapcar #'first args) 18 | ,@default)))) 19 | 20 | (defmacro define-implementation (fun args &body body) 21 | `(defun ,fun ,args 22 | (flet ((fail (&optional message (function ',fun)) 23 | (error 'query-failed :function function :message message))) 24 | (declare (ignorable #'fail)) 25 | ,@body))) 26 | 27 | (define-protocol-fun process-io-bytes () ((unsigned-byte 64) (unsigned-byte 64) (unsigned-byte 64)) 28 | (values 0 0 0)) 29 | 30 | (define-protocol-fun process-room () ((unsigned-byte 64)) 31 | 0) 32 | 33 | (define-protocol-fun process-time () (double-float) 34 | 0d0) 35 | 36 | (define-protocol-fun machine-room () ((unsigned-byte 64) (unsigned-byte 64)) 37 | (values 0 0)) 38 | 39 | (define-protocol-fun machine-cores () ((unsigned-byte 16)) 40 | 1) 41 | 42 | (define-protocol-fun machine-uptime () ((unsigned-byte 64)) 43 | 0) 44 | 45 | (define-protocol-fun machine-time ((core T)) (double-float double-float) 46 | (values 0d0 0d0)) 47 | 48 | (define-protocol-fun thread-time ((thread T)) (double-float) 49 | 0d0) 50 | 51 | (define-protocol-fun thread-core-mask ((thread T)) ((unsigned-byte 64)) 52 | (1- (ash 1 (machine-cores)))) 53 | 54 | (define-protocol-fun (setf thread-core-mask) ((mask (unsigned-byte 64)) (thread T)) ((unsigned-byte 64)) 55 | (thread-core-mask thread)) 56 | 57 | (define-protocol-fun process-priority () ((member :idle :low :normal :high :realtime)) 58 | :normal) 59 | 60 | (define-protocol-fun thread-priority ((thread T)) ((member :idle :low :normal :high :realtime)) 61 | :normal) 62 | 63 | (define-protocol-fun (setf process-priority) ((priority (member :idle :low :normal :high :realtime))) ((member :idle :low :normal :high :realtime)) 64 | :normal) 65 | 66 | (define-protocol-fun (setf thread-priority) ((priority (member :idle :low :normal :high :realtime)) (thread T)) ((member :idle :low :normal :high :realtime)) 67 | :normal) 68 | 69 | (define-protocol-fun gc-room () ((unsigned-byte 64) (unsigned-byte 64)) 70 | #+sbcl 71 | (values (- (sb-ext:dynamic-space-size) (sb-kernel:dynamic-usage)) 72 | (sb-ext:dynamic-space-size)) 73 | #+ccl (let ((free (ccl::%freebytes)) 74 | (used (ccl::%usedbytes))) 75 | (values free 76 | (+ free used))) 77 | #+ecl 78 | (values #+boehm-gc (si:gc-stats T) 79 | #-boehm-gc 0 80 | (ext:get-limit 'ext:heap-size)) 81 | #+clasp 82 | (values (- (sys:dynamic-space-size) (sys:dynamic-usage)) 83 | (sys:dynamic-space-size)) 84 | #+abcl 85 | (let* ((runtime (java:jstatic "getRuntime" 86 | (java:jclass "java.lang.Runtime"))) 87 | ;; TODO: maxMemory? What does this method mean? 88 | (total-memory (java:jcall "totalMemory" runtime)) 89 | (free-memory (java:jcall "freeMemory" runtime))) 90 | (values free-memory total-memory)) 91 | #+clisp 92 | (multiple-value-bind (used room) 93 | (sys::%room) 94 | (values used (+ used room))) 95 | #-(or ccl sbcl ecl clasp abcl clisp) 96 | (values 0 0)) 97 | 98 | (eval-when (:compile-toplevel :load-toplevel :execute) 99 | (defun find-symbol* (name package) 100 | (find-symbol (string name) (string package)))) 101 | 102 | (define-protocol-fun gc-time () (double-float) 103 | #+sbcl 104 | (/ (float #.(or (find-symbol* "*GC-REAL-TIME*" "SB-EXT") 105 | (find-symbol* "*GC-RUN-TIME*" "SB-EXT") 106 | 0d0) 107 | 0d0) 108 | INTERNAL-TIME-UNITS-PER-SECOND) 109 | #+ccl 110 | (/ (float (ccl:gctime) 0d0) 111 | INTERNAL-TIME-UNITS-PER-SECOND) 112 | #+(and ecl (not boehm-gc)) 113 | (/ (float (si::gc-time) 0d0) 114 | INTERNAL-TIME-UNITS-PER-SECOND) 115 | #+clasp 116 | (/ (float (sys:gc-real-time) 0d0) 117 | INTERNAL-TIME-UNITS-PER-SECOND) 118 | #-(or ccl sbcl (and ecl (not boehm-gc)) clasp) 119 | 0d0) 120 | 121 | (define-protocol-fun gpu-room () ((unsigned-byte 64) (unsigned-byte 64)) 122 | (values 0 0)) 123 | 124 | (define-protocol-fun gpu-time () (double-float) 125 | 0d0) 126 | 127 | (define-protocol-fun stack-room () ((unsigned-byte 64) (unsigned-byte 64)) 128 | #+ccl 129 | (multiple-value-bind (stack stack-used) 130 | (ccl::%stack-space) 131 | (values (- stack stack-used) stack)) 132 | #+ecl 133 | (values 0 (ext:get-limit 'ext:lisp-stack)) 134 | #+sbcl 135 | (let* ((stack-total (- sb-vm::*control-stack-end* sb-vm::*control-stack-start*)) 136 | (spaces (ignore-errors 137 | (symbol-value 138 | (or (find-symbol* :+all-spaces+ :sb-vm) 139 | (find-symbol* :+stack-spaces+ :sb-vm)))))) 140 | (values 141 | ;; FIXME: This is implemented the way it is because sometimes 142 | ;; either of +all-spaces+ or +stack-spaces+ is undefined due to 143 | ;; SBCL-internal magic -- aartaka 144 | (- stack-total 145 | (if spaces 146 | (funcall (third (find :control-stack spaces :key #'first))) 147 | stack-total)) 148 | stack-total)) 149 | #-(or ccl ecl sbcl) 150 | (values 0 0)) 151 | 152 | (define-protocol-fun static-room () ((unsigned-byte 64)) 153 | #+ccl 154 | (multiple-value-bind (heap-used static-used staticlib-used frozen-space-size) 155 | (ccl::%usedbytes) 156 | (declare (ignorable heap-used)) 157 | (+ static-used staticlib-used frozen-space-size)) 158 | #+clisp 159 | (nth-value 2 (sys::%room)) 160 | #+sbcl 161 | (let ((spaces (ignore-errors (symbol-value (find-symbol* :+all-spaces+ :sb-vm))))) 162 | (if spaces 163 | (funcall (third (find :static spaces :key #'first))) 164 | 0)) 165 | #+(or ccl clisp sbcl) 166 | 0) 167 | 168 | (define-protocol-fun storage-device ((path (or string pathname))) (string) 169 | (declare (ignore path)) 170 | (fail "Not implemented.")) 171 | 172 | (define-protocol-fun storage-device-path ((device string)) (pathname) 173 | (declare (ignore device)) 174 | (fail "Not implemented.")) 175 | 176 | (define-protocol-fun storage-room ((path (or string pathname))) ((unsigned-byte 64) (unsigned-byte 64)) 177 | (declare (ignore path)) 178 | (values 0 0)) 179 | 180 | (define-protocol-fun storage-io-bytes ((path T)) ((unsigned-byte 64) (unsigned-byte 64) (unsigned-byte 64)) 181 | (declare (ignore path)) 182 | (values 0 0 0)) 183 | 184 | (define-protocol-fun network-devices () (list) 185 | ()) 186 | 187 | (define-protocol-fun network-io-bytes ((device T)) ((unsigned-byte 64) (unsigned-byte 64) (unsigned-byte 64)) 188 | (declare (ignore device)) 189 | (values 0 0 0)) 190 | 191 | (defun os-type () 192 | (or #+(or win32 windows) :WINDOWS 193 | #+(and linux (not android)) :LINUX 194 | #+(and (or darwin macos) (not ios) (not mach)) :DARWIN 195 | #+android :ANDROID 196 | #+ios :IOS 197 | #+(or netbsd net-bsd) :NETBSD 198 | #+(or freebsd free-bsd) :FREEBSD 199 | #+(or openbsd open-bsd) :OPENBSD 200 | #+beos :BEOS 201 | #+solaris :SOLARIS 202 | #+(or react reactos) :REACT 203 | #+(or plan9 p9) :PLAN9 204 | #+mezzano :MEZZANO 205 | #+nx :NX)) 206 | 207 | (define-protocol-fun machine-info () (string string symbol string) 208 | (values "Unknown" "Unknown" (os-type) "Unknown")) 209 | 210 | (define-protocol-fun machine-battery () (double-float double-float symbol) 211 | (values 0.0d0 0.0d0 NIL)) 212 | 213 | (defun arch-type () 214 | (or #+(and x86 (not (or x86-64 amd64))) :X86 215 | #+(or x86-64 amd64) :AMD64 216 | #+(and (or arm armv7 armv6 armv5) (not arm64)) :ARM 217 | #+arm64 :ARM64 218 | #+(and riscv (not riscv64)) :RISCV 219 | #+(or riscv64 rv64) :RISCV64 220 | #+(or ppc power powerpc) :PPC 221 | #+sparc :SPARC)) 222 | 223 | (define-protocol-fun machine-core-info () (string string symbol string) 224 | (values "Unknown" "Unknown" (arch-type) "Unknown")) 225 | 226 | (define-protocol-fun process-info () (pathname pathname string string) 227 | (values *default-pathname-defaults* *default-pathname-defaults* "Unknown" "Unknown")) 228 | 229 | (define-protocol-fun gpu-info () (symbol string string) 230 | (values NIL "Unknown" "Unknown")) 231 | 232 | (define-protocol-fun network-info () ((or string null)) 233 | (values NIL)) 234 | 235 | (define-protocol-fun network-address ((device string)) ((or string null) (or string null) (or string null)) 236 | (declare (ignore device)) 237 | (values NIL NIL NIL)) 238 | -------------------------------------------------------------------------------- /staple.ext.lisp: -------------------------------------------------------------------------------- 1 | (defmethod staple:subsystems ((system (eql (asdf:find-system :machine-state)))) ()) 2 | (defmethod staple:packages ((system (eql (asdf:find-system :machine-state)))) (list (find-package :org.shirakumo.machine-state))) 3 | -------------------------------------------------------------------------------- /test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:org.shirakumo.machine-state.test 2 | (:use #:cl #:parachute) 3 | (:local-nicknames 4 | (#:machine-state #:org.shirakumo.machine-state)) 5 | (:export)) 6 | 7 | (in-package #:org.shirakumo.machine-state.test) 8 | 9 | (define-test machine-state 10 | 11 | ;;;; Machine 12 | 13 | (define-test machine-time 14 | (flet ((test (idle total) 15 | (of-type 'double-float idle) 16 | (of-type 'double-float total) 17 | (is >= 0.0d0 idle) 18 | (is >= 0.0d0 total) 19 | (is > idle total))) 20 | 21 | ;; Test the aggregate 22 | (let ((core-times (loop for i below (machine-state:machine-cores) 23 | collect (multiple-value-list (machine-state:machine-time i))))) 24 | 25 | (multiple-value-bind (cpu-idle cpu-total) (machine-state:machine-time t) 26 | (test cpu-idle cpu-total) 27 | 28 | (let ((nproc (machine-state:machine-cores))) 29 | (dolist (core core-times) 30 | (destructuring-bind (core-idle core-total) core 31 | 32 | ;; Test core against CPU 33 | (is <= cpu-idle core-idle) 34 | (is <= cpu-total core-total) 35 | 36 | ;; Test cores 37 | (test core-idle core-total))) 38 | 39 | (fail (machine-state:machine-time nproc) 'machine-state:query-failed 40 | "Non existant core expected to fail")))))) 41 | 42 | (define-test machine-cores 43 | (let ((nproc (machine-state:machine-cores))) 44 | (of-type '(unsigned-byte 64) nproc) 45 | (is >= 1 nproc))) 46 | 47 | (define-test machine-uptime 48 | (let ((uptime (machine-state:machine-uptime))) 49 | (of-type '(unsigned-byte 64) uptime))) 50 | 51 | (define-test machine-room 52 | (multiple-value-bind (used total) (machine-state:machine-room) 53 | (of-type '(unsigned-byte 64) used) 54 | (of-type '(unsigned-byte 64) total) 55 | (is >= used total))) 56 | 57 | (define-test machine-info 58 | (multiple-value-bind (board model os version) (machine-state:machine-info) 59 | (of-type 'string board) 60 | (of-type 'string model) 61 | (is member '(:WINDOWS :LINUX :DARWIN :ANDROID :IOS :NETBSD :FREEBSD 62 | :OPENBSD :BEOS :SOLARIS :REACT :PLAN9 :MEZZANO :NX 63 | nil) 64 | os) 65 | (of-type 'string version))) 66 | 67 | (define-test machine-core-info 68 | (multiple-value-bind (vendor model arch version) (machine-state:machine-core-info) 69 | (of-type 'string vendor) 70 | (of-type 'string model) 71 | (is member '(:X86 :AMD64 :ARM :ARM64 :RISCV :RISCV64 :PPC :SPARC nil) arch) 72 | (of-type 'string version))) 73 | 74 | (define-test machine-battery 75 | (multiple-value-bind (current full state) (machine-state:machine-battery) 76 | (of-type 'double-float current) 77 | (of-type 'double-float full) 78 | (is member '(:CHARGING :DISCHARGING :FULL nil) state) 79 | (is >= 0.0d0 current) 80 | (is >= 0.0d0 full) 81 | (is <= full current))) 82 | 83 | ;;;; Processes 84 | 85 | (define-test process-io-bytes 86 | (multiple-value-bind (total r w) (machine-state:process-io-bytes) 87 | (of-type '(unsigned-byte 64) total) 88 | (of-type '(unsigned-byte 64) r) 89 | (of-type '(unsigned-byte 64) w) 90 | 91 | (is = (+ r w) total) 92 | (is >= r total) 93 | (is >= w total))) 94 | 95 | (define-test process-time 96 | (let ((time (machine-state:process-time))) 97 | (of-type 'double-float time) 98 | (is >= 0.0d0 time))) 99 | 100 | (define-test process-room 101 | (let ((room (machine-state:process-room))) 102 | (of-type '(unsigned-byte 64) room))) 103 | 104 | (define-test process-priority 105 | (is member '(:IDLE :LOW :NORMAL :HIGH :REALTIME) (machine-state:process-priority))) 106 | 107 | (define-test process-info 108 | (multiple-value-bind (command cwd user group) (machine-state:process-info) 109 | (of-type 'pathname command) 110 | (of-type 'pathname cwd) 111 | (of-type 'string user) 112 | (of-type 'string group))) 113 | 114 | ;;;; Threads 115 | 116 | (define-test thread-time 117 | (let ((time (machine-state:thread-time t))) 118 | (of-type 'double-float time) 119 | (is >= 0.0d0 time))) 120 | 121 | (define-test thread-core-mask 122 | (let ((mask (machine-state:thread-core-mask t))) 123 | (of-type '(unsigned-byte 64) mask) ;; Max 64 bits 124 | (is > 0 mask))) 125 | 126 | (define-test thread-priority 127 | (is member '(:IDLE :LOW :NORMAL :HIGH :REALTIME) (machine-state:thread-priority t))) 128 | 129 | ;;;; GC 130 | 131 | (define-test gc-room 132 | (multiple-value-bind (free total) (machine-state:gc-room) 133 | (of-type '(unsigned-byte 64) free) 134 | (of-type '(unsigned-byte 64) total) 135 | (is <= total free))) 136 | 137 | (define-test gc-time 138 | (let ((time (machine-state:gc-time))) 139 | (of-type 'double-float time) 140 | (is >= 0.0d0 time))) 141 | 142 | ;;;; GPU 143 | 144 | (define-test gpu-room 145 | (multiple-value-bind (free total) (machine-state:gpu-room) 146 | (of-type '(unsigned-byte 64) free) 147 | (of-type '(unsigned-byte 64) total) 148 | (is <= total free))) 149 | 150 | (define-test gpu-time 151 | (let ((time (machine-state:gpu-time))) 152 | (of-type 'double-float time) 153 | (is >= 0.0d0 time))) 154 | 155 | (define-test gpu-info 156 | (multiple-value-bind (vendor model version) (machine-state:gpu-info) 157 | (of-type 'symbol vendor) 158 | (of-type 'string model) 159 | (of-type 'string version))) 160 | 161 | ;;;; Storage 162 | 163 | (define-test storage-room 164 | (multiple-value-bind (free total) (machine-state:storage-room *default-pathname-defaults*) 165 | (of-type '(unsigned-byte 64) free) 166 | (of-type '(unsigned-byte 64) total) 167 | (is <= total free))) 168 | 169 | (define-test storage-io-bytes 170 | (multiple-value-bind (total r w) (machine-state:storage-io-bytes *default-pathname-defaults*) 171 | (of-type '(unsigned-byte 64) total) 172 | (of-type '(unsigned-byte 64) r) 173 | (of-type '(unsigned-byte 64) w) 174 | (is = (+ r w) total) 175 | (is >= r total) 176 | (is >= w total))) 177 | 178 | ;;;; Network 179 | 180 | (define-test network-devices 181 | (let ((devices (machine-state:network-devices))) 182 | (of-type 'list devices) 183 | (is every devices #'stringp))) 184 | 185 | (define-test network-io-bytes 186 | (dolist (dev (machine-state:network-devices)) 187 | (multiple-value-bind (total r w) (machine-state:network-io-bytes dev) 188 | (of-type '(unsigned-byte 64) total) 189 | (of-type '(unsigned-byte 64) r) 190 | (of-type '(unsigned-byte 64) w) 191 | (is = (+ r w) total) 192 | (is >= r total) 193 | (is >= w total)))) 194 | 195 | (define-test network-address 196 | (dolist (dev (machine-state:network-devices)) 197 | (multiple-value-bind (mac ipv4 ipv6) (machine-state:network-address dev) 198 | (of-type '(or null string) mac) 199 | (of-type '(or null string) ipv4) 200 | (of-type '(or null string) ipv6)))) 201 | 202 | (define-test network-info 203 | (of-type '(or null string) (machine-state:network-info))) 204 | 205 | ;;;; Others 206 | 207 | (define-test static-room 208 | (let ((size (machine-state:static-room))) 209 | (of-type '(unsigned-byte 64) size))) 210 | 211 | (define-test stack-room 212 | (multiple-value-bind (free total) (machine-state:stack-room) 213 | (of-type '(unsigned-byte 64) free) 214 | (of-type '(unsigned-byte 64) total) 215 | (is <= total free)))) 216 | -------------------------------------------------------------------------------- /windows.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.machine-state) 2 | 3 | (cffi:define-foreign-library psapi 4 | (:windows "Psapi.dll")) 5 | 6 | (cffi:define-foreign-library ntdll 7 | (:windows "Ntdll.dll")) 8 | 9 | (cffi:define-foreign-library pdh 10 | (:windows "Pdh.dll")) 11 | 12 | (cffi:define-foreign-library iphlpapi 13 | (:windows "Iphlpapi.dll")) 14 | 15 | (cffi:define-foreign-library secur32 16 | (:windows "Secur32.dll")) 17 | 18 | (cffi:define-foreign-library advapi32 19 | (:windows "Advapi32.dll")) 20 | 21 | (cffi:define-foreign-library oleaut32 22 | (:windows "OleAut32.dll")) 23 | 24 | (cffi:use-foreign-library psapi) 25 | (cffi:use-foreign-library ntdll) 26 | 27 | (set 'cl-user::*foreign-system-libraries* 28 | (union (when (boundp 'cl-user::*foreign-system-libraries*) 29 | (symbol-value 'cl-user::*foreign-system-libraries*)) 30 | '(psapi ntdll pdh iphlpapi secur32 advapi32 oleaut32))) 31 | 32 | (defmacro windows-call (function &rest args) 33 | `(unless (cffi:foreign-funcall ,function ,@args) 34 | (fail (org.shirakumo.com-on:error-message)))) 35 | 36 | (defmacro nt-call (function &rest args) 37 | `(let ((value (cffi:foreign-funcall ,function ,@args))) 38 | (unless (= 0 value) 39 | (fail (org.shirakumo.com-on:error-message 40 | (cffi:foreign-funcall "LsaNtStatusToWinError" :uint32 value :ulong)))))) 41 | 42 | (defmacro pdh-call (&rest args) 43 | `(let ((ret (cffi:foreign-funcall ,@args :size))) 44 | (unless (= 0 ret) 45 | (let ((msg (com:error-message ret 'pdh))) 46 | (fail (if (string/= "" msg) 47 | msg 48 | (format NIL "Performance counter call failed with ~d" ret)) 49 | 'machine-time))))) 50 | 51 | (defun process () 52 | (cffi:foreign-funcall "GetCurrentProcess" :pointer)) 53 | 54 | (cffi:defcstruct (io-counters :conc-name io-counters-) 55 | (reads :ullong) 56 | (writes :ullong) 57 | (others :ullong) 58 | (read-bytes :ullong) 59 | (write-bytes :ullong) 60 | (other-bytes :ullong)) 61 | 62 | (define-implementation process-io-bytes () 63 | (cffi:with-foreign-object (io-counters '(:struct io-counters)) 64 | (windows-call "GetProcessIoCounters" 65 | :pointer (process) 66 | :pointer io-counters 67 | :bool) 68 | (values (+ (io-counters-read-bytes io-counters) 69 | (io-counters-write-bytes io-counters) 70 | (io-counters-other-bytes io-counters)) 71 | (io-counters-read-bytes io-counters) 72 | (io-counters-write-bytes io-counters)))) 73 | 74 | (cffi:defcstruct (memory-counters :conc-name memory-counters-) 75 | (cb :uint32) 76 | (page-fault-count :uint32) 77 | (peak-working-set-size :size) 78 | (working-set-size :size) 79 | (quota-peak-paged-pool-usage :size) 80 | (quota-paged-pool-usage :size) 81 | (quota-peak-non-paged-pool-usage :size) 82 | (quota-non-paged-pool-usage :size) 83 | (pagefile-usage :size) 84 | (peak-page-file-usage :size)) 85 | 86 | (define-implementation process-room () 87 | (cffi:with-foreign-objects ((memory-counters '(:struct memory-counters))) 88 | (windows-call "GetProcessMemoryInfo" 89 | :pointer (process) 90 | :pointer memory-counters 91 | :uint32 (cffi:foreign-type-size '(:struct memory-counters)) 92 | :bool) 93 | (memory-counters-working-set-size memory-counters))) 94 | 95 | (define-implementation process-time () 96 | (cffi:with-foreign-objects ((creation-time :uint64) 97 | (exit-time :uint64) 98 | (kernel-time :uint64) 99 | (user-time :uint64)) 100 | (windows-call "GetProcessTimes" 101 | :pointer (process) 102 | :pointer creation-time 103 | :pointer exit-time 104 | :pointer kernel-time 105 | :pointer user-time 106 | :bool) 107 | (convert-file-time (cffi:mem-ref user-time :uint64)))) 108 | 109 | (cffi:defcstruct (memory-status :conc-name memory-status-) 110 | (length :uint32) 111 | (memory-load :uint32) 112 | (total-physical :uint64) 113 | (available-physical :uint64) 114 | (total-page-file :uint64) 115 | (available-page-file :uint64) 116 | (total-virtual :uint64) 117 | (available-virtual :uint64) 118 | (available-extended-virtual :uint64)) 119 | 120 | (define-implementation machine-room () 121 | (cffi:with-foreign-objects ((memory-status '(:struct memory-status))) 122 | (setf (memory-status-length memory-status) 123 | (cffi:foreign-type-size '(:struct memory-status))) 124 | (windows-call "GlobalMemoryStatusEx" 125 | :pointer memory-status 126 | :bool) 127 | (let ((available (memory-status-available-physical memory-status)) 128 | (total (memory-status-total-physical memory-status))) 129 | (values (- total available) 130 | total)))) 131 | 132 | (cffi:defcstruct (system-info :conc-name system-info-) 133 | (oem-id :uint32) 134 | (page-size :uint32) 135 | (minimum-application-address :pointer) 136 | (maximum-application-address :pointer) 137 | (active-processor-mask :uint64) 138 | (number-of-processors :uint32) 139 | (processor-type :uint32) 140 | (allocation-granularity :uint32) 141 | (processor-level :uint16) 142 | (processor-revision :uint16)) 143 | 144 | (define-implementation machine-cores () 145 | (cffi:with-foreign-objects ((system-info '(:struct system-info))) 146 | (cffi:foreign-funcall "GetSystemInfo" 147 | :pointer system-info 148 | :void) 149 | (system-info-number-of-processors system-info))) 150 | 151 | (define-implementation machine-uptime () 152 | (cffi:with-foreign-objects ((time :long-long) 153 | (freq :long-long)) 154 | (windows-call "QueryUnbiasedInterruptTime" :pointer time :bool) 155 | (values (round (cffi:mem-ref time :long-long) 10000000)))) 156 | 157 | (declaim (inline convert-file-time)) 158 | (defun convert-file-time (time) 159 | (* 10d-9 (float time 0d0))) 160 | 161 | (define-implementation machine-time (core) 162 | (etypecase core 163 | ((eql T) 164 | (cffi:with-foreign-objects ((idle-time :uint64) 165 | (kernel-time :uint64) 166 | (user-time :uint64)) 167 | (windows-call "GetSystemTimes" 168 | :pointer idle-time 169 | :pointer kernel-time 170 | :pointer user-time 171 | :bool) 172 | (values (convert-file-time (cffi:mem-ref idle-time :uint64)) 173 | (convert-file-time (+ (cffi:mem-ref kernel-time :uint64) 174 | (cffi:mem-ref idle-time :uint64) 175 | (cffi:mem-ref user-time :uint64)))))) 176 | (integer 177 | (unless (cffi:foreign-library-loaded-p 'pdh) 178 | (cffi:load-foreign-library 'pdh)) 179 | (cffi:with-foreign-objects ((handle :pointer) 180 | (counters :pointer 3) 181 | (type :uint32) 182 | (data :double)) 183 | (pdh-call "PdhOpenQueryW" 184 | :pointer (cffi:null-pointer) 185 | :pointer (cffi:null-pointer) 186 | :pointer handle) 187 | (let ((handle (cffi:mem-ref handle :pointer))) 188 | (unwind-protect 189 | (progn 190 | (flet ((add-counter (i name) 191 | (pdh-call "PdhAddCounterW" 192 | :pointer handle 193 | com:wstring name 194 | :pointer (cffi:null-pointer) 195 | :pointer (cffi:mem-aptr counters :pointer i)))) 196 | (add-counter 0 (format NIL "\\Processor(~d)\\% Processor Time" core)) 197 | (add-counter 1 (format NIL "\\Processor(~d)\\% Idle Time" core)) 198 | (add-counter 2 (format NIL "\\Processor(~d)\\% Privileged Time" core))) 199 | (pdh-call "PdhCollectQueryData" :pointer handle) 200 | (flet ((get-counter (i) 201 | (pdh-call "PdhGetFormattedCounterValue" 202 | :pointer (cffi:mem-aptr counters :pointer i) 203 | :uint32 #x00000200 #|PDH_FMT_DOUBLE|# 204 | :pointer type 205 | :pointer data) 206 | (cffi:mem-ref data :double))) 207 | (let ((proc (get-counter 0)) 208 | (idle (get-counter 1)) 209 | (priv (get-counter 2))) 210 | (values idle (+ proc idle priv))))) 211 | (cffi:foreign-funcall "PdhCloseQuery" :pointer handle))))))) 212 | 213 | (defmacro with-thread-handle ((handle thread &optional (default 0)) &body body) 214 | `(if (or (eql ,thread T) 215 | (eql ,thread (bt:current-thread))) 216 | (let ((,handle (cffi:foreign-funcall "GetCurrentThread" :pointer))) 217 | ,@body) 218 | ,default)) 219 | 220 | (define-implementation thread-time (thread) 221 | (with-thread-handle (handle thread) 222 | (cffi:with-foreign-objects ((creation-time :uint64) 223 | (exit-time :uint64) 224 | (kernel-time :uint64) 225 | (user-time :uint64)) 226 | (windows-call "GetThreadTimes" 227 | :pointer handle 228 | :pointer creation-time 229 | :pointer exit-time 230 | :pointer kernel-time 231 | :pointer user-time 232 | :bool) 233 | (convert-file-time (cffi:mem-ref user-time :uint64))))) 234 | 235 | (cffi:defcstruct (thread-info :conc-name thread-info-) 236 | (exit-status :uint32) 237 | (base-address :pointer) 238 | (process :pointer) 239 | (thread :pointer) 240 | (affinity-mask :uint64) 241 | (priority :long) 242 | (base-priority :long)) 243 | 244 | (define-implementation thread-core-mask (thread) 245 | (with-thread-handle (handle thread (1- (ash 1 (machine-cores)))) 246 | (cffi:with-foreign-objects ((info '(:struct thread-info))) 247 | (cffi:foreign-funcall "NtQueryInformationThread" 248 | :pointer handle 249 | :int #x04 250 | :pointer info 251 | :ulong (cffi:foreign-type-size '(:struct thread-info)) 252 | :uint32) 253 | (thread-info-affinity-mask info)))) 254 | 255 | (define-implementation (setf thread-core-mask) (mask thread) 256 | (with-thread-handle (handle thread (1- (ash 1 (machine-cores)))) 257 | (if (= 0 (cffi:foreign-funcall "SetThreadAffinityMask" 258 | :pointer handle 259 | :uint64 mask 260 | :uint64)) 261 | (fail (org.shirakumo.com-on:error-message)) 262 | mask))) 263 | 264 | (define-implementation process-priority () 265 | (let ((value (cffi:foreign-funcall "GetPriorityClass" :pointer (process)))) 266 | (case (cffi:foreign-funcall "GetPriorityClass" :pointer (process)) 267 | (#x00000000 (fail (org.shirakumo.com-on:error-message))) 268 | (#x00000040 :idle) 269 | (#x00004000 :low) 270 | (#x00000020 :normal) 271 | (#x00000080 :high) 272 | (#x00000100 :realtime) 273 | (T :normal)))) 274 | 275 | (define-implementation (setf process-priority) (priority) 276 | (windows-call "SetPriorityClass" 277 | :pointer (process) 278 | :uint16 (ecase priority 279 | (:idle #x00000040) 280 | (:low #x00004000) 281 | (:normal #x00000020) 282 | (:high #x00000080) 283 | (:realtime #x00000100)) 284 | :bool) 285 | priority) 286 | 287 | (define-implementation thread-priority (thread) 288 | (with-thread-handle (handle thread :normal) 289 | (let ((value (cffi:foreign-funcall "GetThreadPriority" :pointer handle :uint))) 290 | (when (= value 2147483647) 291 | (fail (org.shirakumo.com-on:error-message))) 292 | (cond ((< value -8) :idle) 293 | ((< value 0) :low) 294 | ((= value 0) :normal) 295 | ((< value +8) :high) 296 | (T :realtime))))) 297 | 298 | (define-implementation (setf thread-priority) (thread priority) 299 | (with-thread-handle (handle thread :normal) 300 | (windows-call "SetThreadPriority" 301 | :pointer handle 302 | :int (ecase priority 303 | (:idle -15) 304 | (:low -1) 305 | (:normal 0) 306 | (:high 2) 307 | (:realtime 15)) 308 | :bool) 309 | priority)) 310 | 311 | (define-implementation storage-device (path) 312 | (etypecase path 313 | (pathname (or (pathname-device path) 314 | (pathname-device *default-pathname-defaults*) 315 | "C")) 316 | (string (or (pathname-device (pathname-utils:parse-native-namestring path)) 317 | (pathname-device *default-pathname-defaults*) 318 | "C")))) 319 | 320 | (define-implementation storage-device-path (device) 321 | (make-pathname :device device :directory '(:absolute))) 322 | 323 | (define-implementation storage-room (path) 324 | (cffi:with-foreign-objects ((available-to-caller :int64) 325 | (total :int64) 326 | (available :int64)) 327 | (windows-call "GetDiskFreeSpaceExW" 328 | com:wstring (etypecase path 329 | (string (format NIL "~a:/" path)) 330 | (pathname 331 | (pathname-utils:native-namestring (pathname-utils:to-directory path)))) 332 | :pointer available-to-caller 333 | :pointer total 334 | :pointer available 335 | :bool) 336 | (values (cffi:mem-ref available :int64) 337 | (cffi:mem-ref total :int64)))) 338 | 339 | (cffi:defcstruct (disk-performance :conc-name disk-performance-) 340 | (bytes-read :int64) 341 | (bytes-written :int64) 342 | (read-time :int64) 343 | (write-time :int64) 344 | (idle-time :int64) 345 | (read-count :uint32) 346 | (write-count :uint32) 347 | (queue-depth :uint32) 348 | (split-count :uint32) 349 | (query-time :int64) 350 | (storage-device-number :uint32) 351 | (storage-manager-name :uint16 :count 8)) 352 | 353 | (define-implementation storage-io-bytes (device) 354 | (when (pathnamep device) 355 | (setf device (storage-device device))) 356 | (let ((handle (cffi:foreign-funcall "CreateFileA" 357 | :string (format NIL "\\\\.\\~a:" device) 358 | :uint32 0 359 | :uint32 3 #| FILE_SHARE_READ | FILE_SHARE_WRITE |# 360 | :pointer (cffi:null-pointer) 361 | :uint32 3 #| OPEN_EXISTING |# 362 | :uint32 #x02000000 #| FILE_FLAG_BACKUP_SEMANTICS |# 363 | :pointer (cffi:null-pointer) 364 | :pointer))) 365 | (when (= (cffi:pointer-address handle) #+64-bit (1- (ash 1 64)) #-64-bit (1- (ash 1 32))) 366 | (fail (org.shirakumo.com-on:error-message))) 367 | (unwind-protect 368 | (cffi:with-foreign-objects ((perf '(:struct disk-performance))) 369 | (windows-call "DeviceIoControl" 370 | :pointer handle 371 | :uint32 458784 #| IOCTL_DISK_PERFORMANCE |# 372 | :pointer (cffi:null-pointer) 373 | :uint32 0 374 | :pointer perf 375 | :uint32 (cffi:foreign-type-size '(:struct disk-performance)) 376 | :pointer (cffi:null-pointer) 377 | :pointer (cffi:null-pointer) 378 | :bool) 379 | (values (+ (disk-performance-bytes-read perf) 380 | (disk-performance-bytes-written perf)) 381 | (disk-performance-bytes-read perf) 382 | (disk-performance-bytes-written perf))) 383 | (cffi:foreign-funcall "CloseHandle" :pointer handle)))) 384 | 385 | (cffi:defcstruct (ifrow :size 1352 :conc-name ifrow-) 386 | (alias :uint16 :count 257 :offset 28) 387 | (in-octets :uint64 :offset 1208) 388 | (out-octets :uint64 :offset 1280)) 389 | 390 | (cffi:defcstruct (iftable :conc-name iftable-) 391 | (entries :ulong) 392 | (table (:struct ifrow) :count 128)) 393 | 394 | (define-implementation network-devices () 395 | (unless (cffi:foreign-library-loaded-p 'iphlpapi) 396 | (cffi:load-foreign-library 'iphlpapi)) 397 | (cffi:with-foreign-objects ((table :pointer)) 398 | (let ((ret (cffi:foreign-funcall "GetIfTable2" :pointer table :size))) 399 | (unless (= 0 ret) 400 | (let ((msg (com:error-message ret 'iphlpapi))) 401 | (fail (if (string/= "" msg) msg 402 | (format NIL "GetIfTable2 call failed with ~d" ret)))))) 403 | (let ((table (cffi:mem-ref table :pointer))) 404 | (unwind-protect 405 | (let ((list ())) 406 | (dotimes (i (iftable-entries table) (nreverse list)) 407 | (let* ((row (cffi:mem-aptr (cffi:foreign-slot-pointer table '(:struct iftable) 'table) 408 | '(:struct ifrow) i)) 409 | (name (com:wstring->string 410 | (cffi:foreign-slot-pointer row '(:struct ifrow) 'alias) 411 | 256))) 412 | (push name list)))) 413 | (cffi:foreign-funcall "FreeMibTable" :pointer table))))) 414 | 415 | (define-implementation network-io-bytes (device) 416 | (unless (cffi:foreign-library-loaded-p 'iphlpapi) 417 | (cffi:load-foreign-library 'iphlpapi)) 418 | (cffi:with-foreign-objects ((table :pointer)) 419 | (let ((ret (cffi:foreign-funcall "GetIfTable2" :pointer table :size))) 420 | (unless (= 0 ret) 421 | (let ((msg (com:error-message ret 'iphlpapi))) 422 | (fail (if (string/= "" msg) msg 423 | (format NIL "GetIfTable2 call failed with ~d" ret)))))) 424 | (let ((table (cffi:mem-ref table :pointer))) 425 | (unwind-protect 426 | (etypecase device 427 | ((eql T) 428 | (let ((read 0) (write 0)) 429 | (declare (type (unsigned-byte 64) read write)) 430 | (dotimes (i (iftable-entries table) (values (+ read write) read write)) 431 | (let ((row (cffi:mem-aptr (cffi:foreign-slot-pointer table '(:struct iftable) 'table) 432 | '(:struct ifrow) i))) 433 | (incf read (ifrow-in-octets row)) 434 | (incf write (ifrow-out-octets row)))))) 435 | (string 436 | (dotimes (i (iftable-entries table) (fail "No such device found.")) 437 | (let* ((row (cffi:mem-aptr (cffi:foreign-slot-pointer table '(:struct iftable) 'table) 438 | '(:struct ifrow) i)) 439 | (name (com:wstring->string 440 | (cffi:foreign-slot-pointer row '(:struct ifrow) 'alias) 441 | 256))) 442 | (when (string= name device) 443 | (return (values (+ (ifrow-in-octets row) 444 | (ifrow-out-octets row)) 445 | (ifrow-in-octets row) 446 | (ifrow-out-octets row)))))))) 447 | (cffi:foreign-funcall "FreeMibTable" :pointer table))))) 448 | 449 | (cffi:defcstruct (version-info :conc-name version-info-) 450 | (size :ulong) 451 | (major :ulong) 452 | (minor :ulong) 453 | (build-number :ulong) 454 | (platform-id :ulong) 455 | (csd-version :uint16 :count 128)) 456 | 457 | (cffi:defcstruct (variant :conc-name variant-) 458 | (type :ushort) 459 | (reserved1 :uint16) 460 | (reserved2 :uint16) 461 | (reserved3 :uint16) 462 | (value :pointer)) 463 | 464 | (com:define-guid clsid-wbem-locator #x4590f811 #x1d3a #x11d0 #x89 #x1f #x00 #xaa #x00 #x4b #x2e #x24) 465 | (com:define-guid iid-iwbem-locator #xdc12a687 #x737f #x11cf #x88 #x4d #x00 #xaa #x00 #x4b #x2e #x24) 466 | 467 | (com:define-comstruct i-wbem-locator 468 | (connect-server (network-resource com:wstring) 469 | (user com:wstring) 470 | (password com:wstring) 471 | (locale com:wstring) 472 | (security-flags :long) 473 | (authority com:wstring) 474 | (context :pointer) 475 | (namespace :pointer))) 476 | 477 | (com:define-comstruct i-wbem-services 478 | open-namespace 479 | cancel-async-call 480 | query-object-sink 481 | get-object 482 | get-object-async 483 | put-class 484 | put-class-async 485 | delete-class 486 | delete-class-async 487 | create-class-enum 488 | create-class-enum-async 489 | put-instance 490 | put-instance-async 491 | delete-instance 492 | delete-instance-async 493 | create-instance-enum 494 | create-instance-enum-async 495 | (exec-query (query-language com:wstring) (query com:wstring) (flags :long) (context :pointer) (enumerator :pointer)) 496 | exec-query-async 497 | exec-notification-query 498 | exec-notification-query-async 499 | exec-method 500 | exec-method-async) 501 | 502 | (com:define-comstruct i-enum-wbem-class-object 503 | reset 504 | (next (timeout :long) (count :ulong) (objects :pointer) (returned :pointer)) 505 | next-async 506 | clone 507 | skip) 508 | 509 | (com:define-comstruct i-wbem-class-object 510 | get-qualifier-set 511 | (get (name com:wstring) (flags :long) (value :pointer) (type :pointer) (flavor :pointer)) 512 | put 513 | delete 514 | get-names 515 | begin-enumeration 516 | next 517 | end-enumeration 518 | get-property-qualifier-set 519 | clone 520 | get-object-text 521 | spawn-derived-class 522 | spawn-instance 523 | compare-to 524 | get-property-origin 525 | inherits-from 526 | get-method 527 | put-method 528 | delete-method 529 | begin-method-enumeration 530 | next-method 531 | end-method-enumeration 532 | get-method-qualifier-set 533 | get-method-origin) 534 | 535 | (defun wmi-query (query &rest props) 536 | (unless (cffi:foreign-library-loaded-p 'oleaut32) 537 | (cffi:load-foreign-library 'oleaut32)) 538 | (com:with-com (locator (com:create clsid-wbem-locator iid-iwbem-locator)) 539 | (cffi:with-foreign-objects ((value :pointer) 540 | (status :ulong) 541 | (variant '(:struct variant))) 542 | (i-wbem-locator-connect-server locator "Root\\CIMV2" NIL NIL NIL 0 NIL (cffi:null-pointer) value) 543 | (com:with-com (services (cffi:mem-ref value :pointer)) 544 | (cffi:foreign-funcall "CoSetProxyBlanket" :pointer services 545 | :uint32 10 #| RPC_C_AUTHN_WINNT |# 546 | :uint32 0 #| RPC_C_AUTHZ_NONE |# 547 | :pointer (cffi:null-pointer) 548 | :uint32 3 #| RPC_C_AUTHN_LEVEL_CALL |# 549 | :uint32 3 #| RPC_C_IMP_LEVEL_IMPERSONATE |# 550 | :pointer (cffi:null-pointer) 551 | :uint32 0 #| EOAC_NONE |#) 552 | (i-wbem-services-exec-query services "WQL" query 553 | (logior #x20 #| WBEM_FLAG_FORWARD_ONLY |# 554 | #x10 #| WBEM_FLAG_RETURN_IMMEDIATELY |#) 555 | (cffi:null-pointer) value) 556 | (com:with-com (enumerator (cffi:mem-ref value :pointer)) 557 | (when (cffi:null-pointer-p enumerator) 558 | (fail "WMI query failed.")) 559 | (i-enum-wbem-class-object-next enumerator -1 #| WBEM_INFINITE |# 1 value status) 560 | (unless (= 0 (cffi:mem-ref status :ulong)) 561 | (com:with-com (object (cffi:mem-ref value :pointer)) 562 | (cffi:foreign-funcall "VariantInit" :pointer variant) 563 | (loop for prop in props 564 | do (cffi:foreign-funcall "VariantClear" :pointer variant) 565 | (i-wbem-class-object-get object prop 0 variant (cffi:null-pointer) (cffi:null-pointer)) 566 | collect (case (variant-type variant) 567 | (8 (com:wstring->string (variant-value variant)))))))))))) 568 | 569 | (define-implementation machine-info () 570 | (destructuring-bind (&optional vendor model) (wmi-query "SELECT * FROM Win32_BaseBoard" "Manufacturer" "Product") 571 | (values vendor 572 | model 573 | :windows 574 | (cffi:with-foreign-objects ((version '(:struct version-info))) 575 | (setf (version-info-size version) (cffi:foreign-type-size '(:struct version-info))) 576 | (nt-call "RtlGetVersion" :pointer version :size) 577 | (format NIL "~d.~d-~a" 578 | (version-info-major version) (version-info-minor version) 579 | (version-info-build-number version)))))) 580 | 581 | (define-implementation machine-core-info () 582 | (destructuring-bind (&optional vendor model version) (wmi-query "SELECT * FROM Win32_Processor" "Manufacturer" "Name" "Version") 583 | (values (or vendor "Unknown") 584 | (or model "Unknown") 585 | (arch-type) 586 | (or version "Unknown")))) 587 | 588 | (define-implementation network-info () 589 | (cffi:with-foreign-object (hostname :char 512) 590 | (cffi:foreign-funcall "gethostname" :pointer hostname :size 512 :int) 591 | (cffi:foreign-string-to-lisp hostname :max-chars 512))) 592 | 593 | (define-implementation process-info () 594 | (unless (cffi:foreign-library-loaded-p 'advapi32) 595 | (cffi:load-foreign-library 'advapi32)) 596 | (values 597 | (cffi:with-foreign-object (name :uint16 1024) 598 | (cffi:foreign-funcall "GetModuleFileNameW" :pointer (cffi:null-pointer) :pointer name :uint32 1024 :uint32) 599 | (pathname-utils:parse-native-namestring (com:wstring->string name))) 600 | (pathname-utils:parse-native-namestring 601 | (cffi:with-foreign-object (path :uint16 1024) 602 | (cffi:foreign-funcall "_wgetcwd" :pointer path :size 1024) 603 | (com:wstring->string path)) 604 | :as :directory) 605 | (cffi:with-foreign-objects ((name :uint16 512) 606 | (length :uint32)) 607 | (setf (cffi:mem-ref length :uint32) 512) 608 | (windows-call "GetUserNameW" :pointer name :pointer length :bool) 609 | (com:wstring->string name (cffi:mem-ref length :uint32))) 610 | "Unknown")) 611 | 612 | (cffi:defcstruct (sockaddr4 :conc-name sockaddr4-) 613 | (family :uint16) 614 | (port :uint16) 615 | (addr :uint32)) 616 | 617 | (cffi:defcstruct (sockaddr6 :conc-name sockaddr6-) 618 | (family :ushort) 619 | (port :ushort) 620 | (flow-info :ulong) 621 | (addr :uint16 :count 8) 622 | (scope-id :long)) 623 | 624 | (cffi:defcstruct (address :conc-name address-) 625 | (length :ulong) 626 | (flags :uint32) 627 | (next :pointer) 628 | (sockaddr :pointer) 629 | (sockaddr-length :int)) 630 | 631 | (cffi:defcstruct (adapter :conc-name adapter-) 632 | (padding :unsigned-long-long) 633 | (next :pointer) 634 | (name :string) 635 | (first-unicast-address :pointer) 636 | (first-anycast-address :pointer) 637 | (first-multicast-address :pointer) 638 | (first-dns-server-address :pointer) 639 | (dns-suffix com:wstring) 640 | (description com:wstring) 641 | (friendly-name com:wstring) 642 | (physical-address :uint8 :count 8) 643 | (physical-address-length :ulong)) 644 | 645 | (defun mac-str (octets) 646 | (format NIL "~{~2,'0x~^:~}" (coerce octets 'list))) 647 | 648 | (defun ipv4-str (ipv4) 649 | (format NIL "~d.~d.~d.~d" 650 | (ldb (byte 8 0) ipv4) 651 | (ldb (byte 8 8) ipv4) 652 | (ldb (byte 8 16) ipv4) 653 | (ldb (byte 8 24) ipv4))) 654 | 655 | (defun ipv6-str (ipv6) 656 | (flet ((be->le (i) 657 | (rotatef (ldb (byte 8 0) i) (ldb (byte 8 8) i)) 658 | i)) 659 | (format NIL "~x:~x:~x:~x:~x:~x:~x:~x" 660 | (be->le (cffi:mem-aref ipv6 :uint16 0)) 661 | (be->le (cffi:mem-aref ipv6 :uint16 1)) 662 | (be->le (cffi:mem-aref ipv6 :uint16 2)) 663 | (be->le (cffi:mem-aref ipv6 :uint16 3)) 664 | (be->le (cffi:mem-aref ipv6 :uint16 4)) 665 | (be->le (cffi:mem-aref ipv6 :uint16 5)) 666 | (be->le (cffi:mem-aref ipv6 :uint16 6)) 667 | (be->le (cffi:mem-aref ipv6 :uint16 7))))) 668 | 669 | (define-implementation network-address (device) 670 | (cffi:with-foreign-objects ((size :ulong)) 671 | (setf (cffi:mem-ref size :ulong) 0) 672 | (cffi:foreign-funcall "GetAdaptersAddresses" :ulong 0 :ulong 0 :pointer (cffi:null-pointer) :pointer (cffi:null-pointer) :pointer size) 673 | (cffi:with-foreign-objects ((adapter :char (cffi:mem-ref size :ulong))) 674 | (when (/= 0 (cffi:foreign-funcall "GetAdaptersAddresses" :ulong 0 :ulong 0 :pointer (cffi:null-pointer) :pointer adapter :pointer size :ulong)) 675 | (fail "Failed to query adapters.")) 676 | (loop until (cffi:null-pointer-p adapter) 677 | do (when (or (string-equal device (adapter-friendly-name adapter)) 678 | (string-equal device (adapter-name adapter)) 679 | (string-equal device (adapter-description adapter))) 680 | (let ((mac (mac-str (cffi:foreign-array-to-lisp (adapter-physical-address adapter) (list :array :uint8 (adapter-physical-address-length adapter))))) 681 | (addr (adapter-first-unicast-address adapter)) ipv4 ipv6) 682 | (loop until (cffi:null-pointer-p addr) 683 | do (let ((sockaddr (address-sockaddr addr))) 684 | (case (sockaddr4-family sockaddr) 685 | (2 (setf ipv4 (ipv4-str (sockaddr4-addr sockaddr)))) 686 | (23 (setf ipv6 (ipv6-str (sockaddr6-addr sockaddr)))))) 687 | (setf addr (address-next addr))) 688 | (return (values mac ipv4 ipv6)))) 689 | (setf adapter (adapter-next adapter)) 690 | finally (fail "No such device."))))) 691 | 692 | (cffi:defcstruct (system-power :conc-name system-power-) 693 | (line-status :uint8) 694 | (battery-flag :uint8) 695 | (battery-life-percent :uint8) 696 | (system-status-flag :uint8) 697 | (battery-life-time :uint32) 698 | (battery-full-life-time :uint32)) 699 | 700 | (define-implementation machine-battery () 701 | (cffi:with-foreign-objects ((power '(:struct system-power))) 702 | (windows-call "GetSystemPowerStatus" :pointer power :bool) 703 | (let ((current (system-power-battery-life-percent power))) 704 | (if (= 255 current) 705 | (values 0d0 0d0 NIL) 706 | (values (float current 0d0) 100d0 707 | (cond ((= 100 current) 708 | :full) 709 | ((logbitp 3 (system-power-battery-flag power)) 710 | :charging) 711 | (T 712 | :discharging))))))) 713 | --------------------------------------------------------------------------------