QB64.org Forum

Active Forums => Programs => Topic started by: SpriggsySpriggs on May 08, 2021, 09:31:48 pm

Title: WinAPI Threading (64 Bit)
Post by: SpriggsySpriggs on May 08, 2021, 09:31:48 pm

justsomeguy (https://www.qb64.org/forum/index.php?action=profile;u=821) had started a post (https://www.qb64.org/forum/index.php?topic=3865.0) in the Discussion section of the forum concerning threading in QB64 and I had replied with some code for Windows 64 bit threading using Win32 API code. I thought it deserved its own post since this is quite a feat when using Win32 API functions. The below code is based on the MSDN page on threading here (https://docs.microsoft.com/en-us/windows/win32/procthread/creating-threads). The code uses plenty of Win32 API functions so I hope it can be helpful to others who are venturing into external libraries and the WinAPI. It includes memory allocation functions, thread safe functions, function addresses, and even provides an example of using a QB64 function as a callback and as an exported function. The code I have provided is currently set up to run 20 threads. One can adjust the MAX_THREADS constant to see a different output.

The C++ header that you will need. Save it as threadwin.h

Code: C++: [Select]

1. #include<strsafe.h>
2. int32 FUNC_MYTHREADFUNCTION(ptrszint*_FUNC_MYTHREADFUNCTION_OFFSET_LPPARAM);
3. extern "C"{
4.         __declspec(dllexport) int32 MyThreadFunction(ptrszint*lpParam){
5.                 return FUNC_MYTHREADFUNCTION((lpParam));
6.         }
7. }
8.  
9. int32 sizeoftchar(){
10.         return sizeof(TCHAR);
11. }

And the QB64 code:

Code: QB64: [Select]

1. Option _Explicit
2. $Console:Only
3.  
4. Type MyData
5.     As Long val1, val2
6. End Type
7.  
8. Const BUF_SIZE = 255
9. Const MAX_THREADS = 20
10. Const HEAP_ZERO_MEMORY = &H00000008
11. Const INFINITE = 4294967295
12. Const STD_OUTPUT_HANDLE = -11
13. Const INVALID_HANDLE_VALUE = -1
14.  
15. Const MB_OK = 0
16.  
17. Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H00000100
18. Const FORMAT_MESSAGE_FROM_SYSTEM = &H00001000
19. Const FORMAT_MESSAGE_IGNORE_INSERTS = &H00000200
20. Const LANG_NEUTRAL = &H00
21. Const SUBLANG_DEFAULT = &H01
22.  
23. Const LMEM_ZEROINIT = &H0040
24.  
25. Declare CustomType Library
26.     Function LoadLibrary%& (lpLibFileName As String)
27.     Function GetProcAddress%& (ByVal hModule As _Offset, lpProcName As String)
28.     Sub FreeLibrary (ByVal hLibModule As _Offset)
29.     Function GetLastError& ()
30.     Function HeapAlloc%& (ByVal hHeap As _Offset, Byval dwFlags As Long, Byval dwBytes As _Offset)
31.     Function GetProcessHeap%& ()
32.     Sub ExitProcess (ByVal uExitCode As _Unsigned Long)
33.     Function CreateThread%& (ByVal lpThreadAttributes As _Offset, Byval dwStackSize As _Offset, Byval lpStartAddress As _Offset, Byval lpParameter As _Offset, Byval dwCreationFlags As Long, Byval lpThreadId As _Offset)
34.     Function WaitForMultipleObjects& (ByVal nCount As Long, Byval lpHandles As _Offset, Byval bWaitAll As _Byte, Byval dwMilliseconds As Long)
35.     Sub WaitForMultipleObjects (ByVal nCount As Long, Byval lpHandles As _Offset, Byval bWaitAll As _Byte, Byval dwMilliseconds As Long)
36.     Sub CloseHandle (ByVal hObject As _Offset)
37.     Sub HeapFree (ByVal hHeap As _Offset, Byval dwFlags As Long, Byval lpMem As _Offset)
38.     Sub StringCchPrintf Alias "StringCchPrintfA" (ByVal pszDest As _Offset, Byval cchDest As _Offset, pszFormat As String, Byval arg1 As Long, Byval arg2 As Long)
39.     Sub StringCchPrintf2 Alias "StringCchPrintfA" (ByVal pszDest As _Offset, Byval cchDest As _Offset, pszFormat As String, lpszFunction As String, Byval error As Long, Byval lpMsgBuf As _Offset)
40.     Sub StringCchLength Alias "StringCchLengthA" (ByVal psz As _Offset, Byval cchMax As _Offset, Byval pcchLength As _Offset)
41.     Function GetStdHandle%& (ByVal nStdHandle As Long)
42.     Function CreateMutex%& Alias "CreateMutexA" (ByVal lpMutexAttributes As _Offset, Byval bInitialOwner As Long, Byval lpName As _Offset)
43.     Sub WriteConsole (ByVal hConsoleOutput As _Offset, Byval lpBuffer As _Offset, Byval nNumberOfCharsToWrite As Long, Byval lpNumberOfCharsWritten As _Offset, Byval lpReserved As _Offset)
44.     Sub FormatMessage Alias FormatMessageA (ByVal dwFlags As Long, Byval lpSource As Long, Byval dwMessageId As Long, Byval dwLanguageId As Long, Byval lpBuffer As _Offset, Byval nSize As Long, Byval Arguments As _Offset)
45.     Sub MessageBox Alias "MessageBoxA" (ByVal hWnd As _Offset, Byval lpText As _Offset, lpCaption As String, Byval uType As _Unsigned Long)
46.     Sub LocalFree (ByVal hMem As _Offset)
47.     Function LocalAlloc%& (ByVal uFlags As _Unsigned Long, Byval uBytes As _Unsigned _Offset)
48.     Function lstrlen& Alias "lstrlenA" (ByVal lpString As _Offset)
49.     Function LocalSize%& (ByVal hMem As _Offset)
50. End Declare
51.  
52. Declare Library "threadwin"
53.     Function sizeoftchar& ()
54. End Declare
55.  
56. Declare Library
57.     Function MAKELANGID& (ByVal p As Long, Byval s As Long)
58. End Declare
59.  
60. Dim As _Offset libload: libload = LoadLibrary(Command$(0))
61. Dim As _Offset MyThreadFunc: MyThreadFunc = GetProcAddress(libload, "MyThreadFunction")
62.  
63. Dim As MyData pDataArray(1 To MAX_THREADS)
64. Dim As Long dwThreadIdArray(1 To MAX_THREADS)
65. Dim As _Offset hThreadArray(1 To MAX_THREADS), heap(1 To MAX_THREADS)
66.  
67. Dim As _Offset ghMutex: ghMutex = CreateMutex(0, 0, 0)
68. If ghMutex = 0 Then
69.     ErrorHandler "CreateMutex"
70. End If
71. Dim As Long i
72. For i = 1 To MAX_THREADS
73.     heap(i) = HeapAlloc(GetProcessHeap, HEAP_ZERO_MEMORY, Len(pDataArray(i)))
74.     Dim As _MEM pdata: pdata = _MemNew(8)
75.     _MemPut pdata, pdata.OFFSET, heap(i)
76.     _MemGet pdata, pdata.OFFSET, pDataArray(i)
77.     If heap(i) = 0 Then
78.         ExitProcess 2
79.     End If
80.     pDataArray(i).val1 = i
81.     pDataArray(i).val2 = i + 100
82.     hThreadArray(i) = CreateThread(0, 0, MyThreadFunc, _Offset(pDataArray(i)), 0, _Offset(dwThreadIdArray(i)))
83.     If hThreadArray(i) = 0 Then
84.         ErrorHandler "CreateThread"
85.         ExitProcess 3
86.     End If
87. Next
88. WaitForMultipleObjects MAX_THREADS, _Offset(hThreadArray()), 1, INFINITE
89. For i = 1 To MAX_THREADS
90.     CloseHandle hThreadArray(i)
91.     If heap(i) <> 0 Then
92.         HeapFree GetProcessHeap, 0, heap(i)
93.     End If
94. Next
95. CloseHandle ghMutex
96. _MemFree pdata
97. FreeLibrary libload
98.  
99. Function MyThreadFunction& (lpParam As _Offset)
100.     Dim As String * BUF_SIZE msgBuf
101.     Dim As _Offset hStdout
102.     Dim As Long cchStringSize, dwChars
103.     Dim As MyData MyData
104.     hStdout = GetStdHandle(STD_OUTPUT_HANDLE)
105.     If hStdout = INVALID_HANDLE_VALUE Then
106.         MyThreadFunction = 1
107.     End If
108.     Dim As _MEM PMYDATA: PMYDATA = _MemNew(8)
109.     _MemPut PMYDATA, PMYDATA.OFFSET, lpParam
110.     _MemGet PMYDATA, PMYDATA.OFFSET, MyData
111.     StringCchPrintf _Offset(msgBuf), BUF_SIZE, "Parameters = %d, %d" + Chr$(10) + Chr$(0), MyData.val1, MyData.val2
112.     StringCchLength _Offset(msgBuf), BUF_SIZE, _Offset(cchStringSize)
113.     WriteConsole hStdout, _Offset(msgBuf), cchStringSize, _Offset(dwChars), 0
114.     _MemFree PMYDATA
115.     MyThreadFunction = 0
116. End Function
117.  
118. Sub ErrorHandler (lpszFunction As String)
119.     Dim As _Offset lpMsgBuf, lpDisplayBuf
120.     Dim As Long dw: dw = GetLastError
121.     FormatMessage FORMAT_MESSAGE_ALLOCATE_BUFFER Or FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, 0, dw, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), _Offset(lpMsgBuf), 0, 0
122.     lpDisplayBuf = LocalAlloc(LMEM_ZEROINIT, (lstrlen(lpMsgBuf) + lstrlen(_Offset(lpszFunction)) + 40) * sizeoftchar)
123.     StringCchPrintf2 lpDisplayBuf, LocalSize(lpDisplayBuf) / sizeoftchar, "%s failed with error %d:" + Chr$(10) + " %s" + Chr$(0), lpszFunction + Chr$(0), dw, lpMsgBuf
124.     MessageBox 0, lpDisplayBuf, "Error" + Chr$(0), MB_OK
125.     LocalFree lpMsgBuf
126.     LocalFree lpDisplayBuf
127. End Sub

And a screenshot of the program:
 

Title: Re: WinAPI Threading
Post by: justsomeguy on May 08, 2021, 09:38:05 pm

Great Job! One day I hope to see when QB64 supports threads natively, and perhaps this could be the basis for it.

Text Only | Text with Attachments