'Classes/System/Threading/ThreadPool.ab

Namespace System
Namespace Threading
Namespace Detail

TypeDef PQueueUserWorkItem = *Function(fn As LPTHREAD_START_ROUTINE, context As VoidPtr, flags As DWord) As BOOL

TypeDef PRegisterWaitForSingleObject = *Function(ByRef hNewWaitObject As HANDLE, hObject As HANDLE, Callback As WAITORTIMERCALLBACK, Context As VoidPtr, dwMilliseconds As DWord, dwFlags As DWord) As BOOL

Const WM_QueueUserWorkItem = WM_APP + 100
Const WM_RegisterWaitForSingleObject = WM_APP + 101

Class QueueContextData<T>
Public
	Callback As T
	State As Object

	Sub QueueContextData(c As T, s As Object)
		Callback = c
		State = s
	End Sub
End Class

Class WaitData
Public
	WaitObject As WaitHandle
	Callback As WaitOrTimerCallback
	State As Object

	Sub WaitData(w As WaitHandle, c As WaitOrTimerCallback, s As Object)
		WaitObject = w
		Callback = c
		State = s
	End Sub
End Class

End Namespace

Delegate Sub WaitCallback(state As Object)
Delegate Sub WaitOrTimerCallback(state As Object, timedOut As Boolean)

Class ThreadPool
Public
	Static Function QueueUserWorkItem(callback As WaitCallback, state = Nothing As Object) As Boolean
		startThread()
		Dim qcd = New Detail.QueueContextData<WaitCallback>(callback, state)
		Dim h = ActiveBasic.AllocObjectHandle(qcd)
		PostThreadMessage(thread.ThreadId, Detail.WM_QueueUserWorkItem, 0, h)
	End Function

	'とりあえずタイムアウト非対応
	Static Function RegisterWaitForSingleObject(waitObject As WaitHandle, callback As WaitOrTimerCallback, state As Object) As RegisteredWaitHandle
		startThread()
		Dim wd = New Detail.WaitData(waitObject, callback, state)
		Dim h = ActiveBasic.AllocObjectHandle(wd)
		PostThreadMessage(thread.ThreadId, Detail.WM_RegisterWaitForSingleObject, 0, h)
	End Function
/*
	Static Function RegisterWaitForSingleObject(waitObject As WaitHandle, callback As WaitOrTimerCallback, state As Object, millisecondsTimeOutInterval As DWord, executeOnlyOnce As Boolean) As RegisteredWaitHandle
	End Function
*/
Private
	Static Function waitCallback(param As VoidPtr) As DWord
		Try
			Diagnostics.Debug.Assert(param <> 0)
			Dim qcd = ActiveBasic.ReleaseObjectHandle(param As LONG_PTR) As Detail.QueueContextData<WaitCallback>
			With qcd
				Diagnostics.Debug.Assert(.Callback <> 0)
				Dim c = .Callback
				c(.State)
			End With
		Catch e As Object
		End Try
	End Function

	Static Sub waitOrTimerCallback(param As VoidPtr, TimerOrWaitFired As BOOLEAN)
		Try
			Diagnostics.Debug.Assert(param <> 0)
			Dim qcd = ActiveBasic.ReleaseObjectHandle(param As LONG_PTR) As Detail.QueueContextData<WaitOrTimerCallback>
			With qcd
				Diagnostics.Debug.Assert(.Callback <> 0)
				Dim c = .Callback
				c(.State, TimerOrWaitFired)
			End With
		Catch e As Object
		End Try
	End Sub

	Static Sub startThread()
		If ActiveBasic.IsNothing(thread) Then
			Dim lock = New ActiveBasic.Windows.CriticalSectionLock(_System_CriticalSection)
			thread = New Thread(AddressOf(poolThread), 0)
			thread.Name = "ThreadPool"
			thread.Start()
			While isMessageQueueCreated = False
				Sleep(1)
			Wend
			lock.Dispose()
		End If
	End Sub

	Static Function poolThread(pv As VoidPtr) As DWord
		Try
			Dim msg As MSG
			PeekMessage(msg, 0, WM_USER, WM_USER, PM_NOREMOVE) 'メッセージキューの作成
			isMessageQueueCreated = True
			Dim waitList = New Collections.Generic.List<Detail.WaitData>
			Dim handles = waitListToArrayOfHANDLE(waitList)
			Do
				While PeekMessage(msg, 0, 0, 0, PM_REMOVE)
					Select Case msg.message
						Case WM_QUIT
							Exit Do
						Case Detail.WM_QueueUserWorkItem
							waitCallback(msg.lParam As VoidPtr)
						Case Detail.WM_RegisterWaitForSingleObject
							Diagnostics.Debug.Assert(msg.lParam <> 0)
							Dim wd = ActiveBasic.ReleaseObjectHandle(msg.lParam) As Detail.WaitData
							waitList.Add(wd)
							handles = waitListToArrayOfHANDLE(waitList)
					End Select
				Wend
				Dim retWait = MsgWaitForMultipleObjects(waitList.Count As DWord, handles, FALSE, INFINITE, QS_ALLINPUT)
				If retWait = &hffffffff Then
					poolThread = retWait
					Exit Do
				ElseIf WAIT_OBJECT_0 <= retWait And retWait < WAIT_OBJECT_0 + waitList.Count Then
					Dim i = retWait - WAIT_OBJECT_0
					Dim wd = waitList[i]
					With wd
						Dim c = wd.Callback
						c(wd.State, False)
					End With
					waitList.RemoveAt(i)
					handles = waitListToArrayOfHANDLE(waitList)
				End If
			Loop
		Catch e As Object
			Diagnostics.Trace.WriteLine("ThreadPool thread catches an exception:")
			Diagnostics.Trace.WriteLine(e.ToString)
		End Try
	End Function

	Static Function waitListToArrayOfHANDLE(waitList As Collections.Generic.List<Detail.WaitData>) As *HANDLE
		Diagnostics.Debug.Assert(Not ActiveBasic.IsNothing(waitList))
		waitListToArrayOfHANDLE = GC_malloc(waitList.Count * SizeOf(HANDLE))
		Dim count = waitList.Count
		Dim i As Long
		For i = 0 To ELM(count)
			waitListToArrayOfHANDLE[i] = waitList.Item[i].WaitObject.Handle
		Next
	End Function

	Static thread = Nothing As Thread
	Static isMessageQueueCreated = False As Boolean
End Class

Class RegisteredWaitHandle
End Class
#ifdef __UNDEFINED__
Class ThreadPool
Public
	Static Function QueueUserWorkItem(callback As WaitCallback, state = Nothing As Object) As Boolean
		Dim pfn = GetProcAddress(GetModuleHandle("kernel32"), ToMBStr("QueueUserWorkItem")) As Detail.PQueueUserWorkItem
		If pfn = 0 Then
			'ToDo: 自前実装
			Throw New NotSupportedException("RegisterWaitForSingleObject requires Windows 2000")
		End If
		Dim qcd = New Detail.QueueContextData<WaitCallback>(callback, state)
		Dim h = ActiveBasic.AllocObjectHandle(qcd)
		pfn(AddressOf (waitCallback), h As VoidPtr, WT_EXECUTELONGFUNCTION)
	End Function

	Static Function RegisterWaitForSingleObject(waitObject As WaitHandle, callback As WaitOrTimerCallback, state As Object, millisecondsTimeOutInterval As DWord, executeOnlyOnce As Boolean) As RegisteredWaitHandle
		Dim pfn = GetProcAddress(GetModuleHandle("kernel32"), ToMBStr("RegisterWaitForSingleObject")) As Detail.PRegisterWaitForSingleObject
		If pfn = 0 Then
			'ToDo: 自前実装
			Throw New NotSupportedException("RegisterWaitForSingleObject requires Windows 2000")
		End If
		Dim qcd = New Detail.QueueContextData<WaitOrTimerCallback>(callback, state)
		Dim h = ActiveBasic.AllocObjectHandle(qcd)
		Dim wo As HANDLE
		pfn(wo, waitObject.Handle, 0, 0 As VoidPtr, 0, WT_EXECUTELONGFUNCTION)
'		pfn(wo, waitObject.Handle, AddressOf (waitOrTimerCallback), h As VoidPtr, millisecondsTimeOutInterval, WT_EXECUTELONGFUNCTION)
	End Function

Private
	Static Function waitCallback(param As VoidPtr) As DWord
		Try
			Diagnostics.Debug.Assert(param <> 0)
			Dim qcd = ActiveBasic.ReleaseObjectHandle(param As LONG_PTR) As Detail.QueueContextData<WaitCallback>
			With qcd
				Diagnostics.Debug.Assert(.Callback <> 0)
				Dim c = .Callback
				c(.State)
			End With
		Catch e As Object
		End Try
	End Function

	Static Sub waitOrTimerCallback(param As VoidPtr, TimerOrWaitFired As BOOLEAN)
		Try
			Diagnostics.Debug.Assert(param <> 0)
			Dim qcd = ActiveBasic.ReleaseObjectHandle(param As LONG_PTR) As Detail.QueueContextData<WaitOrTimerCallback>
			With qcd
				Diagnostics.Debug.Assert(.Callback <> 0)
				Dim c = .Callback
				c(.State, TimerOrWaitFired)
			End With
		Catch e As Object
		End Try
	End Sub
End Class

Class RegisteredWaitHandle
End Class

#endif

End Namespace
End Namespace