1 | 'Classes/System/Threading/ThreadPool.ab
|
---|
2 |
|
---|
3 | Namespace System
|
---|
4 | Namespace Threading
|
---|
5 | Namespace Detail
|
---|
6 |
|
---|
7 | TypeDef PQueueUserWorkItem = *Function(fn As LPTHREAD_START_ROUTINE, context As VoidPtr, flags As DWord) As BOOL
|
---|
8 |
|
---|
9 | TypeDef PRegisterWaitForSingleObject = *Function(ByRef hNewWaitObject As HANDLE, hObject As HANDLE, Callback As WAITORTIMERCALLBACK, Context As VoidPtr, dwMilliseconds As DWord, dwFlags As DWord) As BOOL
|
---|
10 |
|
---|
11 | Const WM_QueueUserWorkItem = WM_APP + 100
|
---|
12 | Const WM_RegisterWaitForSingleObject = WM_APP + 101
|
---|
13 |
|
---|
14 | Class QueueContextData<T>
|
---|
15 | Public
|
---|
16 | Callback As T
|
---|
17 | State As Object
|
---|
18 |
|
---|
19 | Sub QueueContextData(c As T, s As Object)
|
---|
20 | Callback = c
|
---|
21 | State = s
|
---|
22 | End Sub
|
---|
23 | End Class
|
---|
24 |
|
---|
25 | Class WaitData
|
---|
26 | Public
|
---|
27 | WaitObject As WaitHandle
|
---|
28 | Callback As WaitOrTimerCallback
|
---|
29 | State As Object
|
---|
30 |
|
---|
31 | Sub WaitData(w As WaitHandle, c As WaitOrTimerCallback, s As Object)
|
---|
32 | WaitObject = w
|
---|
33 | Callback = c
|
---|
34 | State = s
|
---|
35 | End Sub
|
---|
36 | End Class
|
---|
37 |
|
---|
38 | End Namespace
|
---|
39 |
|
---|
40 | Delegate Sub WaitCallback(state As Object)
|
---|
41 | Delegate Sub WaitOrTimerCallback(state As Object, timedOut As Boolean)
|
---|
42 |
|
---|
43 | Class ThreadPool
|
---|
44 | Public
|
---|
45 | Static Function QueueUserWorkItem(callback As WaitCallback, state = Nothing As Object) As Boolean
|
---|
46 | startThread()
|
---|
47 | Dim qcd = New Detail.QueueContextData<WaitCallback>(callback, state)
|
---|
48 | Dim h = ActiveBasic.AllocObjectHandle(qcd)
|
---|
49 | PostThreadMessage(thread.ThreadId, Detail.WM_QueueUserWorkItem, 0, h)
|
---|
50 | End Function
|
---|
51 |
|
---|
52 | 'とりあえずタイムアウト非対応
|
---|
53 | Static Function RegisterWaitForSingleObject(waitObject As WaitHandle, callback As WaitOrTimerCallback, state As Object) As RegisteredWaitHandle
|
---|
54 | startThread()
|
---|
55 | Dim wd = New Detail.WaitData(waitObject, callback, state)
|
---|
56 | Dim h = ActiveBasic.AllocObjectHandle(wd)
|
---|
57 | PostThreadMessage(thread.ThreadId, Detail.WM_RegisterWaitForSingleObject, 0, h)
|
---|
58 | End Function
|
---|
59 | /*
|
---|
60 | Static Function RegisterWaitForSingleObject(waitObject As WaitHandle, callback As WaitOrTimerCallback, state As Object, millisecondsTimeOutInterval As DWord, executeOnlyOnce As Boolean) As RegisteredWaitHandle
|
---|
61 | End Function
|
---|
62 | */
|
---|
63 | Private
|
---|
64 | Static Function waitCallback(param As VoidPtr) As DWord
|
---|
65 | Try
|
---|
66 | Diagnostics.Debug.Assert(param <> 0)
|
---|
67 | Dim qcd = ActiveBasic.ReleaseObjectHandle(param As LONG_PTR) As Detail.QueueContextData<WaitCallback>
|
---|
68 | With qcd
|
---|
69 | Diagnostics.Debug.Assert(.Callback <> 0)
|
---|
70 | Dim c = .Callback
|
---|
71 | c(.State)
|
---|
72 | End With
|
---|
73 | Catch e As Object
|
---|
74 | End Try
|
---|
75 | End Function
|
---|
76 |
|
---|
77 | Static Sub waitOrTimerCallback(param As VoidPtr, TimerOrWaitFired As BOOLEAN)
|
---|
78 | Try
|
---|
79 | Diagnostics.Debug.Assert(param <> 0)
|
---|
80 | Dim qcd = ActiveBasic.ReleaseObjectHandle(param As LONG_PTR) As Detail.QueueContextData<WaitOrTimerCallback>
|
---|
81 | With qcd
|
---|
82 | Diagnostics.Debug.Assert(.Callback <> 0)
|
---|
83 | Dim c = .Callback
|
---|
84 | c(.State, TimerOrWaitFired)
|
---|
85 | End With
|
---|
86 | Catch e As Object
|
---|
87 | End Try
|
---|
88 | End Sub
|
---|
89 |
|
---|
90 | Static Sub startThread()
|
---|
91 | If ActiveBasic.IsNothing(thread) Then
|
---|
92 | Dim lock = New ActiveBasic.Windows.CriticalSectionLock(_System_CriticalSection)
|
---|
93 | thread = New Thread(AddressOf(poolThread), 0)
|
---|
94 | thread.Name = "ThreadPool"
|
---|
95 | thread.Start()
|
---|
96 | While isMessageQueueCreated = False
|
---|
97 | Sleep(1)
|
---|
98 | Wend
|
---|
99 | lock.Dispose()
|
---|
100 | End If
|
---|
101 | End Sub
|
---|
102 |
|
---|
103 | Static Function poolThread(pv As VoidPtr) As DWord
|
---|
104 | Try
|
---|
105 | Dim msg As MSG
|
---|
106 | PeekMessage(msg, 0, WM_USER, WM_USER, PM_NOREMOVE) 'メッセージキューの作成
|
---|
107 | isMessageQueueCreated = True
|
---|
108 | Dim waitList = New Collections.Generic.List<Detail.WaitData>
|
---|
109 | Dim handles = waitListToArrayOfHANDLE(waitList)
|
---|
110 | Do
|
---|
111 | While PeekMessage(msg, 0, 0, 0, PM_REMOVE)
|
---|
112 | Select Case msg.message
|
---|
113 | Case WM_QUIT
|
---|
114 | Exit Do
|
---|
115 | Case Detail.WM_QueueUserWorkItem
|
---|
116 | waitCallback(msg.lParam As VoidPtr)
|
---|
117 | Case Detail.WM_RegisterWaitForSingleObject
|
---|
118 | Diagnostics.Debug.Assert(msg.lParam <> 0)
|
---|
119 | Dim wd = ActiveBasic.ReleaseObjectHandle(msg.lParam) As Detail.WaitData
|
---|
120 | waitList.Add(wd)
|
---|
121 | handles = waitListToArrayOfHANDLE(waitList)
|
---|
122 | End Select
|
---|
123 | Wend
|
---|
124 | Dim retWait = MsgWaitForMultipleObjects(waitList.Count As DWord, handles, FALSE, INFINITE, QS_ALLINPUT)
|
---|
125 | If retWait = &hffffffff Then
|
---|
126 | poolThread = retWait
|
---|
127 | Exit Do
|
---|
128 | ElseIf WAIT_OBJECT_0 <= retWait And retWait < WAIT_OBJECT_0 + waitList.Count Then
|
---|
129 | Dim i = retWait - WAIT_OBJECT_0
|
---|
130 | Dim wd = waitList[i]
|
---|
131 | With wd
|
---|
132 | Dim c = wd.Callback
|
---|
133 | c(wd.State, False)
|
---|
134 | End With
|
---|
135 | waitList.RemoveAt(i)
|
---|
136 | handles = waitListToArrayOfHANDLE(waitList)
|
---|
137 | End If
|
---|
138 | Loop
|
---|
139 | Catch e As Object
|
---|
140 | Diagnostics.Trace.WriteLine("ThreadPool thread catches an exception:")
|
---|
141 | Diagnostics.Trace.WriteLine(e.ToString)
|
---|
142 | End Try
|
---|
143 | End Function
|
---|
144 |
|
---|
145 | Static Function waitListToArrayOfHANDLE(waitList As Collections.Generic.List<Detail.WaitData>) As *HANDLE
|
---|
146 | Diagnostics.Debug.Assert(Not ActiveBasic.IsNothing(waitList))
|
---|
147 | waitListToArrayOfHANDLE = GC_malloc(waitList.Count * SizeOf(HANDLE))
|
---|
148 | Dim count = waitList.Count
|
---|
149 | Dim i As Long
|
---|
150 | For i = 0 To ELM(count)
|
---|
151 | waitListToArrayOfHANDLE[i] = waitList.Item[i].WaitObject.Handle
|
---|
152 | Next
|
---|
153 | End Function
|
---|
154 |
|
---|
155 | Static thread = Nothing As Thread
|
---|
156 | Static isMessageQueueCreated = False As Boolean
|
---|
157 | End Class
|
---|
158 |
|
---|
159 | Class RegisteredWaitHandle
|
---|
160 | End Class
|
---|
161 | #ifdef __UNDEFINED__
|
---|
162 | Class ThreadPool
|
---|
163 | Public
|
---|
164 | Static Function QueueUserWorkItem(callback As WaitCallback, state = Nothing As Object) As Boolean
|
---|
165 | Dim pfn = GetProcAddress(GetModuleHandle("kernel32"), ToMBStr("QueueUserWorkItem")) As Detail.PQueueUserWorkItem
|
---|
166 | If pfn = 0 Then
|
---|
167 | 'ToDo: 自前実装
|
---|
168 | Throw New NotSupportedException("RegisterWaitForSingleObject requires Windows 2000")
|
---|
169 | End If
|
---|
170 | Dim qcd = New Detail.QueueContextData<WaitCallback>(callback, state)
|
---|
171 | Dim h = ActiveBasic.AllocObjectHandle(qcd)
|
---|
172 | pfn(AddressOf (waitCallback), h As VoidPtr, WT_EXECUTELONGFUNCTION)
|
---|
173 | End Function
|
---|
174 |
|
---|
175 | Static Function RegisterWaitForSingleObject(waitObject As WaitHandle, callback As WaitOrTimerCallback, state As Object, millisecondsTimeOutInterval As DWord, executeOnlyOnce As Boolean) As RegisteredWaitHandle
|
---|
176 | Dim pfn = GetProcAddress(GetModuleHandle("kernel32"), ToMBStr("RegisterWaitForSingleObject")) As Detail.PRegisterWaitForSingleObject
|
---|
177 | If pfn = 0 Then
|
---|
178 | 'ToDo: 自前実装
|
---|
179 | Throw New NotSupportedException("RegisterWaitForSingleObject requires Windows 2000")
|
---|
180 | End If
|
---|
181 | Dim qcd = New Detail.QueueContextData<WaitOrTimerCallback>(callback, state)
|
---|
182 | Dim h = ActiveBasic.AllocObjectHandle(qcd)
|
---|
183 | Dim wo As HANDLE
|
---|
184 | pfn(wo, waitObject.Handle, 0, 0 As VoidPtr, 0, WT_EXECUTELONGFUNCTION)
|
---|
185 | ' pfn(wo, waitObject.Handle, AddressOf (waitOrTimerCallback), h As VoidPtr, millisecondsTimeOutInterval, WT_EXECUTELONGFUNCTION)
|
---|
186 | End Function
|
---|
187 |
|
---|
188 | Private
|
---|
189 | Static Function waitCallback(param As VoidPtr) As DWord
|
---|
190 | Try
|
---|
191 | Diagnostics.Debug.Assert(param <> 0)
|
---|
192 | Dim qcd = ActiveBasic.ReleaseObjectHandle(param As LONG_PTR) As Detail.QueueContextData<WaitCallback>
|
---|
193 | With qcd
|
---|
194 | Diagnostics.Debug.Assert(.Callback <> 0)
|
---|
195 | Dim c = .Callback
|
---|
196 | c(.State)
|
---|
197 | End With
|
---|
198 | Catch e As Object
|
---|
199 | End Try
|
---|
200 | End Function
|
---|
201 |
|
---|
202 | Static Sub waitOrTimerCallback(param As VoidPtr, TimerOrWaitFired As BOOLEAN)
|
---|
203 | Try
|
---|
204 | Diagnostics.Debug.Assert(param <> 0)
|
---|
205 | Dim qcd = ActiveBasic.ReleaseObjectHandle(param As LONG_PTR) As Detail.QueueContextData<WaitOrTimerCallback>
|
---|
206 | With qcd
|
---|
207 | Diagnostics.Debug.Assert(.Callback <> 0)
|
---|
208 | Dim c = .Callback
|
---|
209 | c(.State, TimerOrWaitFired)
|
---|
210 | End With
|
---|
211 | Catch e As Object
|
---|
212 | End Try
|
---|
213 | End Sub
|
---|
214 | End Class
|
---|
215 |
|
---|
216 | Class RegisteredWaitHandle
|
---|
217 | End Class
|
---|
218 |
|
---|
219 | #endif
|
---|
220 |
|
---|
221 | End Namespace
|
---|
222 | End Namespace
|
---|