ThreadData.bas #1

Attribute VB_Name = "modThreadData"
Option Explicit
'***************************************************************
' (c) Copyright 2000 Matthew J. Curland
'
' This file is from the CD-ROM accompanying the book:
' Advanced Visual Basic 6: Power Techniques for Everyday Programs
'   Author: Matthew Curland
'   Published by: Addison-Wesley, July 2000
'   ISBN: 0-201-70712-8
'   http://www.PowerVB.com
'
' You are entitled to license free distribution of any application
'   that uses this file if you own a copy of the book, or if you
'   have obtained the file from a source approved by the author. You
'   may redistribute this file only with express written permission
'   of the author.
'
' This file depends on:
'   References:
'     VBoostTypes6.olb (VBoost Object Types (6.0))
'     ThreadAPI.olb (VBoost: API declares used for threading)
'     VBoost6.Dll (VBoost Object Implementation (6.0)) (optional)
'   Files:
'     ThreadControl.cls
'     ThreadLaunch.cls
'     ThreadProc.bas
'     ArrayOwner.bas or ArrayOwnerIgnoreOnly.bas
'   Minimal VBoost conditionals:
'     None
'   Conditional Compilation Values:
'     NOVBOOST = 1 'Removes VBoost dependency
'
' This file is discussed in Chapter 13.
'***************************************************************
Private Type OwnedThreadData
    Owner As ArrayOwner
    pSA() As ThreadData
End Type
Private m_Data As OwnedThreadData
'Allocate a ThreadData object on the heap and transfer the
'bits from the incoming structure.
Public Function NewThreadData(InitData As ThreadData) As Long
    With m_Data
        If .Owner.SA.cDims = 0 Then
            InitArrayOwner .Owner, LenB(.pSA(0)), VBoostTypes.FADF_AUTO Or VBoostTypes.FADF_FIXEDSIZE
        End If
        NewThreadData = VBoostTypes.CoTaskMemAlloc(LenB(.pSA(0)))
        If NewThreadData = 0 Then Err.Raise 7 'Out of memory
        VBoostTypes.CopyMemory ByVal NewThreadData, InitData.CLSID, LenB(.pSA(0))
        VBoostTypes.ZeroMemory InitData.CLSID, LenB(.pSA(0))
    End With
End Function
Public Sub DestroyThreadData(ByVal pThreadData As Long)
    With m_Data
        .Owner.SA.pvData = pThreadData
        With .pSA(0)
            'This shouldn't happen, but a safety valve is good
            If .ThreadHandle Then ThreadingAPIs.CloseHandle .ThreadHandle
        End With
        'Frees any leftover Variant information and
        'the controller
        Erase .pSA
    End With
    VBoostTypes.CoTaskMemFree pThreadData
End Sub
Public Property Let ThreadHandle(ByVal pThreadData As Long, ByVal RHS As Long)
    'This takes over ownership of the ThreadHandle
    With m_Data
        .Owner.SA.pvData = pThreadData
        .pSA(0).ThreadHandle = RHS
    End With
End Property
Public Sub GetOutputData(ByVal pThreadData As Long, hr As Long, ExitCode As Long, OutputData As Variant)
    With m_Data
        .Owner.SA.pvData = pThreadData
        With .pSA(0)
            #If NOVBOOST Then
                OutputData = Empty
                VBoostTypes.CopyMemory ByVal VarPtr(OutputData), ByVal VarPtr(.OutputData), 16
                VBoostTypes.CopyMemory ByVal VarPtr(.OutputData), 0, 2
            #Else
                VBoost.MoveVariant OutputData, .OutputData
            #End If
            ExitCode = .ExitCode
            hr = .hr
        End With
    End With
End Sub
Private Function ThreadCompleted(ThreadData As ThreadData) As Boolean
Dim ExitCode As Long
    With ThreadData
        ThreadCompleted = .ThreadDone
        If ThreadCompleted Then
            'ThreadDone pointer is incremented, there is a chance
            'that we are signaled, but the thread hasn't yet
            'terminated.  In this case, just claim we aren't done
            'yet to make sure that code on all worker threads is
            'actually completed before ThreadControl terminates.
            If .ThreadHandle Then
                If ThreadingAPIs.GetExitCodeThread(.ThreadHandle, ExitCode) Then
                    If ExitCode = ThreadingAPIs.STILL_ACTIVE Then
                        ThreadCompleted = False
                        Exit Function
                    End If
                End If
                ThreadingAPIs.CloseHandle .ThreadHandle
                .ThreadHandle = 0
                .InputData = Empty
                .ExitCode = ExitCode
            End If
        End If
    End With
End Function
Private Sub SignalThread(ThreadData As ThreadData, ByRef fUnregistered As Boolean, ByVal pCritSect As Long, ByRef fInCriticalSection As Boolean)
    'ThreadDone and ThreadSignalPtr must be checked/modified inside
    'a critical section because ThreadDone could change on some
    'threads while we are signalling, causing ThreadSignalPtr to point
    'to invalid memory, as well as other problems. The parameters to this
    'function are provided to ensure that the critical section is entered
    'only when necessary. If fInCriticalSection is set, then the caller
    'must call LeaveCriticalSection on pCritSect. This is left up to the
    'caller since this function is designed to be called on multiple instances
    'in a tight loop. There is no point in repeatedly entering/leaving the
    'critical section.
    With ThreadData
        If Not .fSignaled Then
            If .ThreadSignalPtr Then
                If Not fInCriticalSection Then
                    ThreadingAPIs.EnterCriticalSection pCritSect
                    fInCriticalSection = True
                End If
                If .ThreadDone = 0 Then
                    ThreadingAPIs.InterlockedIncrement .ThreadSignalPtr
                End If
                'No point in signalling twice
                .fSignaled = True
            Else
                'The worker hasn't set ThreadSignalPtr
                fUnregistered = True
            End If
        End If
    End With
End Sub
Public Sub StopThreads(RunningThreads As Collection, FinishedThreads As Collection, ByVal pCritSect As Long)
Dim fInCriticalSection As Boolean
Dim fSignal As Boolean
Dim fUnregistered As Boolean
Dim Iter As Variant
Dim pThreadData As Long
Dim DataKey As String
    fSignal = True
    With m_Data
        Do
            fUnregistered = False
            For Each Iter In RunningThreads
                pThreadData = Iter
                .Owner.SA.pvData = pThreadData
                If ThreadCompleted(.pSA(0)) Then
                    DataKey = CStr(pThreadData)
                    RunningThreads.Remove DataKey
                    If .pSA(0).fKeepData Then
                        Set .pSA(0).Controller = Nothing
                        FinishedThreads.Add pThreadData, DataKey
                    Else
                        'Note: Don't call DestroyThreadData while
                        '.pSA(0) is a current With context.
                        DestroyThreadData pThreadData
                    End If
                    DataKey = vbNullString
                ElseIf fSignal Then
                    'See note in SignalThread about CriticalSection usage.
                    SignalThread .pSA(0), fUnregistered, pCritSect, fInCriticalSection
                End If
            Next
            If fInCriticalSection Then
                ThreadingAPIs.LeaveCriticalSection pCritSect
                fInCriticalSection = False
            Else
                'We can turn this off indefinitely if
                'fUnregistered is False because all threads
                'will have been signaled at this point.
                fSignal = fUnregistered
            End If
            If RunningThreads.Count = 0 Then Exit Do
            'Give up the rest of our time slice
            ThreadingAPIs.Sleep 0
        Loop
    End With
End Sub
Public Sub CleanThreads(RunningThreads As Collection, FinishedThreads As Collection)
Dim pThreadData As Long
Dim Iter As Variant
Dim DataKey As String
    With m_Data
        For Each Iter In RunningThreads
            pThreadData = Iter
            .Owner.SA.pvData = pThreadData
            If ThreadCompleted(.pSA(0)) Then
                DataKey = CStr(pThreadData)
                RunningThreads.Remove DataKey
                If .pSA(0).fKeepData Then
                    Set .pSA(0).Controller = Nothing
                    FinishedThreads.Add pThreadData, DataKey
                Else
                    'Note: Don't call DestroyThreadData while
                    '.pSA(0) is a current With context.
                    DestroyThreadData pThreadData
                End If
                DataKey = vbNullString
            End If
        Next
    End With
End Sub

Public Sub SignalThreads(RunningThreads As Collection, FinishedThreads As Collection, ByVal pCritSect As Long)
Dim pThreadData As Long
Dim Iter As Variant
Dim fInCriticalSection As Boolean
Dim fUnregistered As Boolean 'Dummy
Dim DataKey As String
    With m_Data
        For Each Iter In RunningThreads
            pThreadData = Iter
            .Owner.SA.pvData = pThreadData
            If ThreadCompleted(.pSA(0)) Then
                DataKey = CStr(pThreadData)
                RunningThreads.Remove DataKey
                If .pSA(0).fKeepData Then
                    Set .pSA(0).Controller = Nothing
                    FinishedThreads.Add pThreadData, DataKey
                Else
                    'Note: Don't call DestroyThreadData while
                    '.pSA(0) is a current With context.
                    DestroyThreadData pThreadData
                End If
                DataKey = vbNullString
            Else
                'See note in SignalThread about CriticalSection usage.
                SignalThread .pSA(0), fUnregistered, pCritSect, fInCriticalSection
            End If
        Next
        If fInCriticalSection Then ThreadingAPIs.LeaveCriticalSection pCritSect
    End With
End Sub