source: trunk/ab5.0/ablib/src/Classes/System/Threading/ThreadPool.ab@ 599

'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, 0, 0, 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)
                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