PlanetSquires Forums

Please login or register.

Login with username, password and session length
Advanced search  
Pages: 1 [2]

Author Topic: Freebasic Thread Pool  (Read 1421 times)

Pierre Bellisle

  • FireFly3 User
  • Junior FireFly Member
  • *
  • Posts: 57
Re: Freebasic Thread Pool
« Reply #15 on: May 26, 2017, 12:21:09 AM »

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

Pierre
Logged

Josť Roca

  • FireFly3 Registered User
  • Master FireFly Member
  • *
  • Posts: 2785
    • Josť Roca Software
Re: Freebasic Thread Pool
« Reply #16 on: May 26, 2017, 12:29:00 AM »

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

Must have skipped it accidentally.

Code: [Select]
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
« Last Edit: May 26, 2017, 12:32:19 AM by Josť Roca »
Logged

Pierre Bellisle

  • FireFly3 User
  • Junior FireFly Member
  • *
  • Posts: 57
Re: Freebasic Thread Pool
« Reply #17 on: May 26, 2017, 01:34:52 AM »

Thank you  Josť.  :-)
Pierre
Logged

Richard Kelly

  • FireFly3 Registered User
  • Senior FireFly Member
  • *
  • Posts: 318
Re: Freebasic Thread Pool
« Reply #18 on: May 26, 2017, 10:49:35 AM »

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
Logged

Pierre Bellisle

  • FireFly3 User
  • Junior FireFly Member
  • *
  • Posts: 57
Re: Freebasic Thread Pool
« Reply #19 on: May 26, 2017, 12:55:33 PM »

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

Pierre

Code: [Select]
#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

'______________________________________________________________________________
'
« Last Edit: May 31, 2017, 02:01:25 PM by Pierre Bellisle »
Logged

Richard Kelly

  • FireFly3 Registered User
  • Senior FireFly Member
  • *
  • Posts: 318
Re: Freebasic Thread Pool
« Reply #20 on: May 26, 2017, 04:53:27 PM »

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]
#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).



« Last Edit: May 26, 2017, 06:30:38 PM by Richard Kelly »
Logged

Richard Kelly

  • FireFly3 Registered User
  • Senior FireFly Member
  • *
  • Posts: 318
Re: Freebasic Thread Pool
« Reply #21 on: May 31, 2017, 09:56:28 AM »

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
Logged
Pages: 1 [2]