Freebasic Thread Pool

[Pierre Bellisle]

Your code works fine for me too Richard, both 32 and 64...

Pierre

[José Roca]

> Jose, I did not find CloseThreadpoolCleanupGroupMembers() in your includes?

Must have skipped it accidentally.

Code Select Expand


DECLARE SUB CloseThreadpoolCleanupGroupMembers IMPORT "KERNEL32.DLL" ALIAS "CloseThreadpoolCleanupGroupMembers" ( _
   BYVAL ptpp AS DWORD _                                ' __in PTP_CLEANUP_GROUP ptpcg
, BYVAL fCancelPendingCallbacks AS LONG _              ' __BOOL fCancelPendingCallbacks
, BYVAL pvCleanupContext AS DWORD _                    ' __PVOID pvCleanupContext
)                                                      ' void


[Pierre Bellisle]

Thank you  Jose.  :-)
Pierre

[Richard Kelly]

Since I think during program shutdown, it is best to let all outstanding threads complete, I'll also have to come up with a way to determine if there are any outstanding threads still running.

I'm beginning to like these threadpool api's. Adding the following will allow all outstanding callbacks/threads to complete which is what I want to do.

CreateThreadpoolCleanupGroup

SetThreadpoolCallbackCleanupGroup

CloseThreadpoolCleanupGroupMembers

This api will wait for all callbacks to finish. It also releases objects so it is not necessary to call any close functions.

CloseThreadpoolCleanupGroup


Maybe this is best encapsulated into it's own object class.

Rick

[Pierre Bellisle]

For the fun of it, same MSDN thread pool example, this time ported to FreeBASIC.

Pierre

Code Select Expand


#Define JumpCompiler "<D:\Free\64\fbc.exe>"
#Define JumpCompilerCmd "<-s console>"

#Lang "fb"
#Define Unicode

Const _WIN32_WINNT = &h0602

#Include Once "Windows.bi"
#Include Once "Win\WinNT.bi"
#Include Once "Win\WinBase.bi"

#Macro InitializeThreadpoolEnvironment(pcbe)
  TpInitializeCallbackEnviron(pcbe)
#EndMacro

#Macro SetThreadpoolCallbackPool(pcbe, ptpp)
  TpSetCallbackThreadpool(pcbe, ptpp)
#EndMacro

#Macro SetThreadpoolCallbackCleanupGroup(pcbe, ptpcg, pfng)
   TpSetCallbackCleanupGroup(pcbe, ptpcg, pfng)
#EndMacro
'_____________________________________________________________________________
'
Function MyWaitCallback(Instance_ As PTP_CALLBACK_INSTANCE, Parameter As Long, Wait_ As PTP_WAIT, WaitResult As TP_WAIT_RESULT) As Long

Print "MyWaitCallback: Wait is over."
Function = 1

End Function
'_____________________________________________________________________________

Function MyTimerCallback(Instance_ As PTP_CALLBACK_INSTANCE, Parameter As Long, Timer_ As PTP_TIMER) As Long

'Do something when the timer fires.
  Print "MyTimerCallback: Timer has fired."
  Function = 1

End Function
'_____________________________________________________________________________

Function MyWorkCallback(Instance_ As PTP_CALLBACK_INSTANCE, Parameter As Long, Work As PTP_WORK) As Long

  Print "MyWorkCallback: Task performed."
  Function = 1

End Function
'_____________________________________________________________________________

Sub DemoCleanupPersistentWorkTimer()
Dim bRet            As Long
Dim work            As PTP_WORK
Dim timer_          As PTP_TIMER
Dim pool            As PTP_POOL
Dim CallBackEnviron As TP_CALLBACK_ENVIRON
Dim cleanupgroup    As PTP_CLEANUP_GROUP
Dim FileDueTime     As FILETIME
Dim ulDueTime       As ULongInt
Dim rollback        As DWORD

InitializeThreadpoolEnvironment(@CallBackEnviron)

'Create a custom, dedicated thread pool.
pool = CreateThreadpool(ByVal NULL)
If pool = 0 Then
   Print "CreateThreadpool failed. LastError:" & Str$(GetLastError())
   GoTo main_cleanup
End If

rollback = 1 'Pool creation succeeded

'The thread pool is made persistent simply by setting
'both the minimum and maximum threads to 1.
SetThreadpoolThreadMaximum(ByVal pool, 1)

bRet = SetThreadpoolThreadMinimum(ByVal pool, 1)
If bRet = 0 Then
   Print "SetThreadpoolThreadMinimum failed. LastError:" & Str$(GetLastError())
   GoTo main_cleanup
End If

'Create a cleanup group for this thread pool.
cleanupgroup = CreateThreadpoolCleanupGroup()
If cleanupgroup = 0 Then
   Print "CreateThreadpoolCleanupGroup failed. LastError:" & Str$(GetLastError())
   GoTo main_cleanup
End If

rollback = 2 'Cleanup group creation succeeded

'Associate the callback environment with our thread pool.
SetThreadpoolCallbackPool(@CallBackEnviron, pool)

'Associate the cleanup group with our thread pool.
'Objects created with the same callback environment
'as the cleanup group become members of the cleanup group.
SetThreadpoolCallbackCleanupGroup(@CallBackEnviron, cleanupgroup, NULL)

'Create work with the callback environment.
work = CreateThreadpoolWork(Cast(Any Pointer, @MyWorkCallback), ByVal NULL, @CallBackEnviron)
If work = 0 Then
   Print "CreateThreadpoolWork failed. LastError:" & Str$(GetLastError())
   GoTo main_cleanup
End  If

rollback = 3 'Creation of work succeeded

'Submit the work to the pool. Because this was a pre-allocated
'work item (using CreateThreadpoolWork), it is guaranteed to execute.
SubmitThreadpoolWork(ByVal work)

'Create a timer with the same callback environment.
timer_ = CreateThreadpoolTimer(Cast(Any Pointer, @MyTimerCallback), ByVal NULL, @CallBackEnviron)
If timer_ = 0 Then
   Print "CreateThreadpoolTimer failed. LastError:" & Str$(GetLastError())
   GoTo main_cleanup
End If

rollback = 4 'Timer creation succeeded

'Set the timer to fire in one second.

ulDueTime = -(1 * 10 * 1000 * 1000)
FileDueTime.dwHighDateTime = ((Cast(ULong, ulDueTime) And &hFFFFFFFF00000000) Shr 32)
FileDueTime.dwLowDateTime = ((Cast(ULong, ulDueTime) And &hFFFFFFFF))
SetThreadpoolTimer(ByVal timer_, @FileDueTime, 0, 0)

'Delay for the timer to be fired
Sleep(1500)

'Wait for all callbacks to finish.
'CloseThreadpoolCleanupGroupMembers also releases objects
'that are members of the cleanup group, so it is not necessary
'to call close functions on individual objects
'after calling CloseThreadpoolCleanupGroupMembers.

CloseThreadpoolCleanupGroupMembers(ByVal cleanupgroup, FALSE, NULL)

'Already cleaned up the work item with the
'CloseThreadpoolCleanupGroupMembers, so set rollback to 2.
rollback = 2
GoTo main_cleanup

main_cleanup:

'Clean up any individual pieces manually
'Notice the fall-through structure of the switch.
'Clean up in reverse order.
Select Case rollback

   Case 3: 'Clean up the cleanup group members.
           CloseThreadpoolCleanupGroupMembers(ByVal cleanupgroup, FALSE, NULL)
   Case 2: 'Clean up the cleanup group.
           CloseThreadpoolCleanupGroup(ByVal cleanupgroup)

   Case 1: 'Clean up the pool.
           CloseThreadpool(ByVal pool)

End Select

End Sub
'_____________________________________________________________________________

Sub DemoNewRegisterWait()
Dim Wait_        As PTP_WAIT
Dim hEvent       As HANDLE
Dim i            As Long
Dim rollback     As Long

'Create an auto-reset event.
hEvent = CreateEvent(NULL, FALSE, FALSE, "")

If hEvent = 0 Then
   Print "Error Handling"
   Exit Sub
End  If

rollback = 1 'CreateEvent succeeded

Wait_ = CreateThreadpoolWait(Cast(Any Pointer, @MyWaitCallback), ByVal NULL, NULL)

If Wait_ = 0 Then
   Print "CreateThreadpoolWait failed. LastError:" & Str$(GetLastError())
   GoTo new_wait_cleanup
End If

rollback = 2 'CreateThreadpoolWait succeeded

'Need to re-register the event with the wait object
'each time before signaling the event to trigger the wait callback.
For i = 0 To 4
   SetThreadpoolWait(ByVal Wait_, ByVal hEvent, ByVal NULL)

   SetEvent(hEvent)

   'Delay for the waiter thread to act if necessary.
   Sleep(500)

   'Block here until the callback function is done executing.
   WaitForThreadpoolWaitCallbacks(ByVal Wait_, FALSE)
Next

new_wait_cleanup:

Select Case rollback

   Case 2 'Unregister the wait by setting the event to NULL.
     SetThreadpoolWait(ByVal Wait_, NULL, NULL)
     'Close the wait.
     CloseThreadpoolWait(ByVal Wait_)

   Case 1
     'Close the event.
     CloseHandle(hEvent)

End Select

End Sub
'_____________________________________________________________________________

DemoNewRegisterWait()

DemoCleanupPersistentWorkTimer()

Print "Press a key or click to end"
Dim MB As Long : Do : GetMouse(0, 0, 0, MB) : If MB Or Len(InKey) Then Exit Do : End If : Sleep 10 : Loop

'______________________________________________________________________________
'

[Richard Kelly]

Well, I haven't tried to compile this yet, but everything I wanted went into a rather small class attached.

*** Update ***

I got home and fixed up all my finger coding checks. Attachment now updated.

Save the attachment in inc/cCTSQL and now the test script looks like:

Code Select Expand


#INCLUDE ONCE "cCTSQL/cCTServerThreadPool.bi"

declare sub myThread (byval Instance as PTP_CALLBACK_INSTANCE, byval Context as PVOID, byval Work as PTP_WORK)
dim shared lpCriticalSection as CRITICAL_SECTION

dim oThreadPool       as cCTServerThreadPool
dim iError            as long
dim iIndex            as integer

if oThreadPool.StartupStatus(iError) = False THEN
   
print "CreateThreadPool failed,error=" + str(iError)

      Print "press q to quit"
Do
     Sleep 1, 1
Loop Until Inkey = "q"   
     
      END
   
END IF

InitializeCriticalSection(ByVal VarPtr(lpCriticalSection))
   
for iIndex = 1 to 10
   
oThreadPool.CreateThreadWork(cast(PTP_WORK_CALLBACK,@myThread),cast(PVOID,iIndex))
   
NEXT

oThreadPool.ShutdownThreadPool()


      Print "press q to quit"
Do
     Sleep 1, 1
Loop Until Inkey = "q"

end

DeleteCriticalSection(ByVal VarPtr(lpCriticalSection))

sub myThread (byval Instance as PTP_CALLBACK_INSTANCE, byval Context as PVOID, byval Work as PTP_WORK)

EnterCriticalSection(ByVal VarPtr(lpCriticalSection))

print "Thread started,Instance=" + str(Instance) + ",Context=" + str(Context)

LeaveCriticalSection(ByVal VarPtr(lpCriticalSection))

end sub


The ShutdownThreadPool does seem to wait for all callbacks/threads to finish (it does it asynchronously).

[Richard Kelly]

You can follow Dave Roberts from the PB forums on his thread pool journey in the FB forums at:

http://www.freebasic.net/forum/viewtopic.php?f=6&t=25697