-
-
Notifications
You must be signed in to change notification settings - Fork 6
/
toolkit.lisp
128 lines (114 loc) · 4.74 KB
/
toolkit.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
(in-package #:org.shirakumo.fraf.harmony)
(defun ease-linear (x)
(declare (optimize speed))
(declare (type single-float x))
x)
(defun ease-cubic-in (x)
(declare (optimize speed))
(declare (type single-float x))
(expt x 3))
(defun ease-cubic-out (x)
(declare (optimize speed))
(declare (type single-float x))
(1+ (expt (1- x) 3)))
(defun ease-cubic-in-out (x)
(declare (optimize speed))
(declare (type single-float x))
(if (< x 0.5)
(/ (expt (* 2 x) 3) 2)
(1+ (/ (expt (* 2 (1- x)) 3) 2))))
(defmacro push* (value place)
(let ((val (gensym "VAL"))
(old (gensym "OLD")))
`(loop with ,val = ,value
for ,old = ,place
until (atomics:cas ,place ,old (list* ,val ,old)))))
(defmacro pop* (place)
(let ((old (gensym "OLD")))
`(loop for ,old = ,place
until (atomics:cas ,place ,old (rest ,old))
finally (return (car ,old)))))
(defmethod segment ((idx integer) (chain mixed:chain) &optional (errorp T))
(let ((segments (mixed:segments chain)))
(if (<= 0 idx (1- (length segments)))
(aref (mixed:segments chain) idx)
(when errorp (error "No segment at index~% ~d" idx)))))
(defmethod segment (name (chain mixed:chain) &optional (errorp T))
(or (loop for segment across (mixed:segments chain)
do (when (equal name (name segment))
(return segment)))
(when errorp (error "No segment with name~% ~s" name))))
(defun find-symbol* (package name)
(loop (restart-case
(return (or (and (find-package (string package))
(find-symbol (string name) (string package)))
(error "Symbol ~a:~a is not present." (string package) (string name))))
(retry ()
:report "Retry the evaluation")
(use-value (value)
:report "Supply a symbol to use"
(return value)))))
(defmacro lazy-symbol (package name)
`(find-symbol* ,(string package) ,(string name)))
(defun add-to (target &rest parts)
(dolist (part parts target)
(mixed:add part target)))
(defun removef (plist &rest keys)
(loop for (key val) on plist by #'cddr
for found = (member key keys)
unless found collect key
unless found collect val))
(defun set-process-priority (&optional (priority :normal))
#+windows
(cffi:foreign-funcall "SetPriorityClass"
:pointer (cffi:foreign-funcall "GetCurrentProcess" :pointer)
:uint16 (ecase priority
(:idle #x00000040)
(:low #x00004000)
(:normal #x00000020)
(:high #x00000080)
(:realtime #x00000100))
:bool)
#+unix
(cffi:foreign-funcall "setpriority"
:int 0 :uint32 0 :int
(ecase priority
(:idle 19)
(:low 5)
(:normal 0)
(:high -5)
(:realtime -20))
:int))
(defun set-thread-priority (&optional (priority :normal))
#+windows
(cffi:foreign-funcall "SetThreadPriority"
:pointer (cffi:foreign-funcall "GetCurrentThread" :pointer)
:int (ecase priority
(:idle -15)
(:low -1)
(:normal 0)
(:high 2)
(:realtime 15))
:bool)
#+linux ;; Turns out linux violates the posix spec and niceness is the way to go.
(set-process-priority priority)
#+(and unix (not linux))
(cffi:with-foreign-objects ((policy :int)
(param :int))
(cffi:foreign-funcall "pthread_getschedparam"
:pointer (cffi:foreign-funcall "pthread_self" :pointer)
: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)))
(cffi:foreign-funcall "pthread_setschedparam"
:pointer (cffi:foreign-funcall "pthread_self" :pointer)
:int policy
:pointer param
:int))))