-
-
Notifications
You must be signed in to change notification settings - Fork 3
/
posix.lisp
193 lines (171 loc) · 6.66 KB
/
posix.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
(in-package #:org.shirakumo.machine-state)
(cffi:defcvar (errno "errno") :int64)
(defmacro posix-call (function &rest args)
`(let ((val (cffi:foreign-funcall ,function ,@args)))
(if (= -1 val)
(fail (cffi:foreign-funcall "strerror" :int64 errno))
val)))
(defmacro posix-call0 (function &rest args)
`(let ((val (cffi:foreign-funcall ,function ,@args)))
(if (/= 0 val)
(fail (cffi:foreign-funcall "strerror" :int64 errno))
val)))
(cffi:defcstruct (timeval :conc-name timeval-)
(sec :uint64)
(usec :uint64))
(cffi:defcstruct (rusage :conc-name rusage-)
(utime (:struct timeval))
(stime (:struct timeval))
;; Linux fields
(maxrss :long)
(ixrss :long)
(idrss :long)
(isrss :long)
(minflt :long)
(majflt :long)
(nswap :long)
(inblock :long)
(oublock :long)
(msgsnd :long)
(msgrcv :long)
(nsignals :long)
(nvcsw :long)
(nivcsw :long))
(define-implementation process-room ()
(cffi:with-foreign-object (rusage '(:struct rusage))
(posix-call "getrusage" :int 0 :pointer rusage :int)
(* 1024 (+ (rusage-ixrss rusage)
(rusage-idrss rusage)
(rusage-isrss rusage)))))
(define-implementation process-time ()
(cffi:with-foreign-object (rusage '(:struct rusage))
(posix-call "getrusage" :int 0 :pointer rusage :int)
(+ (timeval-sec rusage)
(* (timeval-usec rusage) 10d-7))))
(cffi:defcstruct (sysinfo :conc-name sysinfo-)
(uptime :long)
(loads :ulong :count 3)
(total-ram :ulong)
(free-ram :ulong)
(shared-ram :ulong)
(buffer-ram :ulong)
(total-swap :ulong)
(free-swap :ulong)
(processes :ushort)
(total-high :ulong)
(free-high :ulong)
(memory-unit :uint)
(_pad :char :count 22))
(define-implementation machine-room ()
(cffi:with-foreign-objects ((sysinfo '(:struct sysinfo)))
(posix-call "sysinfo" :pointer sysinfo :int)
(let ((total (sysinfo-total-ram sysinfo))
(free (sysinfo-free-ram sysinfo)))
(values (- total free) total))))
(define-implementation machine-cores ()
;; _SC_NPROCESSORS_ONLN 84
(posix-call "sysconf" :int 84 :long))
(define-implementation machine-uptime ()
(cffi:with-foreign-objects ((sysinfo '(:struct sysinfo)))
(posix-call "sysinfo" :pointer sysinfo :int)
(sysinfo-uptime sysinfo)))
(defmacro with-thread-handle ((handle thread &optional (default 0)) &body body)
`(if (or (eql ,thread T)
(eql ,thread (bt:current-thread)))
(let ((,handle (cffi:foreign-funcall "pthread_self" :pointer)))
,@body)
,default))
(define-implementation thread-time (thread)
(with-thread-handle (handle thread 0d0)
(cffi:with-foreign-object (rusage '(:struct rusage))
(posix-call "getrusage" :int 1 :pointer rusage :int)
(+ (timeval-sec rusage)
(* (timeval-usec rusage) 10d-7)))))
(define-implementation thread-core-mask (thread)
(with-thread-handle (handle thread (1- (ash 1 (machine-cores))))
(cffi:with-foreign-objects ((cpuset :uint64))
(posix-call0 "pthread_getaffinity_np" :pointer handle :size (cffi:foreign-type-size :uint64) :pointer cpuset :int)
(cffi:mem-ref cpuset :uint64))))
(define-implementation (setf thread-core-mask) (mask thread)
(with-thread-handle (handle thread (1- (ash 1 (machine-cores))))
(cffi:with-foreign-objects ((cpuset :uint64))
(setf (cffi:mem-ref cpuset :uint64) mask)
(posix-call0 "pthread_setaffinity_np" :pointer handle :size (cffi:foreign-type-size :uint64) :pointer cpuset :int)
(cffi:mem-ref cpuset :uint64))))
(define-implementation process-priority ()
(let ((err errno)
(value (cffi:foreign-funcall "getpriority" :int 0 :uint32 0 :int)))
(when (and (= -1 value) (/= err errno))
(fail (cffi:foreign-funcall "strerror" :int64 errno)))
(cond ((< value -8) :realtime)
((< value 0) :high)
((= value 0) :normal)
((< value +8) :low)
(T :idle))))
(define-implementation (setf process-priority) (priority)
(let ((prio (ecase priority
(:idle 19)
(:low 5)
(:normal 0)
(:high -5)
(:realtime -20))))
(posix-call0 "setpriority" :int 0 :uint32 0 :int prio :int))
priority)
(define-implementation thread-priority (thread)
(with-thread-handle (handle thread :normal)
(cffi:with-foreign-objects ((policy :int)
(param :int))
(posix-call0 "pthread_getschedparam" :pointer handle :pointer policy :pointer param :int)
(let ((priority (cffi:mem-ref param :int)))
(cond ((< priority 20) :idle)
((< priority 50) :low)
((= priority 50) :normal)
((< priority 70) :high)
(T :realtime))))))
(define-implementation (setf thread-priority) (thread priority)
(with-thread-handle (handle thread :normal)
(cffi:with-foreign-objects ((policy :int)
(param :int))
(posix-call0 "pthread_getschedparam" :pointer handle :pointer policy :pointer param :int)
(let ((policy (cffi:mem-ref policy :int)))
(setf (cffi:mem-ref param :int) (ecase priority
(:idle 1)
(:low 40)
(:normal 50)
(:high 60)
(:realtime 99)))
(posix-call0 "pthread_setschedparam" :pointer handle :int policy :pointer param :int)))
priority))
#-darwin
(cffi:defcstruct (statvfs :size 112 :conc-name statvfs-)
(bsize :uint64 :offset 0)
(frsize :uint64 :offset 8)
(blocks :uint64 :offset 16)
(bfree :uint64 :offset 24)
(bavail :uint64 :offset 32)
(files :uint64 :offset 40)
(ffree :uint64 :offset 48)
(favail :uint64 :offset 56)
(fsid :uint64 :offset 64)
(flag :uint64 :offset 72)
(namemax :uint64 :offset 80))
#+darwin
(cffi:defcstruct (statvfs :size 64 :conc-name statvfs-)
(bsize :uint64 :offset 0)
(frsize :uint64 :offset 8)
(blocks :uint32 :offset 16)
(bfree :uint32 :offset 20)
(bavail :uint32 :offset 24)
(files :uint32 :offset 28)
(ffree :uint32 :offset 32)
(favail :uint32 :offset 36)
(fsid :uint64 :offset 40)
(flag :uint64 :offset 48)
(namemax :uint64 :offset 56))
(define-implementation storage-room (path)
(cffi:with-foreign-objects ((statvfs '(:struct statvfs)))
(posix-call "statvfs" :string (pathname-utils:native-namestring path) :pointer statvfs :int)
(values (* (statvfs-bavail statvfs)
(statvfs-bsize statvfs))
(* (statvfs-blocks statvfs)
(statvfs-bsize statvfs)))))