Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0760: Lightweight-Threading mit Fibers

VB 5/6-Tipp 0760: Lightweight-Threading mit Fibers

 von idiv

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CallWindowProcA (CallWindowProc), RtlMoveMemory (CopyMemory), GetSystemTimeAsFileTime, VirtualAlloc, ConvertFiberToThread (W32CConvertFiberToThread), ConvertThreadToFiber (W32ConvertThreadToFiber), CreateFiber (W32CreateFiber), DeleteFiber (W32DeleteFiber), Sleep (W32Sleep), SwitchToFiber (W32SwitchToFiber)

Download: Download des Beispielprojektes [6.28 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Beschriftungsfeld "Label4"
' Steuerelement: Beschriftungsfeld "Label3"
' Steuerelement: Beschriftungsfeld "Label2"
' Steuerelement: Beschriftungsfeld "Label1"
'Flag zum sauberen entladen der Form
Private UnloadFlag As Boolean

Private Sub Command1_Click()

Dim f1 As Long, f2 As Long

'Neue Fibers erzeugen und Id speichern
f1 = Fibers.CreateFiber(AddressOf FiberProc1, 1)
f2 = Fibers.CreateFiber(AddressOf FiberProc2, 2)

'Demo. Wechselt zwischen den verschiedenen Fibers und löscht selbige zu bestimmten
'Zeitpunkten wieder
Dim i As Long

Label1.Caption = "0"
Label2.Caption = "0"
Label3.Caption = "0"
Label4.Caption = "Läuft..."

Do
    'Überprüfen, ob ein entladen des Dialogs angefordert wurde und Schleife bei Bedarf abbrechen
    If (UnloadFlag = True) Then
        Exit Do
    End If

    'Eigentliche Aufgabe der Schleife durchführen
    Label1.Caption = CStr(CLng(Label1.Caption) + 1)
    DoEvents
    
    'Scheduler aufrufen; Fiber wird dadurch gewechselt, wenn die Zeitscheibendauer vorüber ist
    If (Fibers.Schedule = True) Then
        i = i + 1 'Wert erhöhen, wenn neuer Fiber scheduled wurde
        
        If (i Mod 5) = 0 Then
            'Ab und an den aktuellen Fiber kurz pausieren lassen
            Fibers.Sleep 1000
        End If
    End If
    
    'Bei Bedarf andere Fibers löschen bzw. Schleife verlassen
    If i = 20 Then
        Fibers.DeleteFiber f1
    ElseIf i = 40 Then
        Exit Do
    End If
    
    
    
Loop

Label4.Caption = "Ende"

'Sichergehen, dass alle Fibers gelöscht werden
Fibers.CleanUp

'Überprüfen, ob ein entladen des Dialogs angefordert wurde. Da die obige Schleife das Entladen blockiert,
'wurde die Form bisher nicht vollständig entladen.
If (UnloadFlag = True) Then
    Unload Me
End If

End Sub

Private Sub Form_Unload(Cancel As Integer)

UnloadFlag = True

End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'---------- Anfang Modul "MFiber" alias MFiber.bas ----------
'Die einzige(!) Fiber-Klasse im Projekt
Public Fibers As New CFiber

Public Type FiberData
    Fiber As Long
    Id As Long
    UserProc As Long
    UserParam As Long
    LastTimeSlice As Currency
    SleepTimeout As Currency
    DeletionPending As Boolean
End Type

Private Declare Function VirtualAlloc Lib "kernel32.dll" (ByRef lpAddress As Any, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private Const MEM_COMMIT As Long = &H1000
Private Const PAGE_EXECUTE_READWRITE As Long = &H40

Private Declare Function CallWindowProc Lib "user32" _
                         Alias "CallWindowProcA" ( _
                         ByVal lpPrevWndFunc As Long, _
                         ByVal hWnd As Long, _
                         ByVal Msg As Long, _
                         ByVal wParam As Long, _
                         ByVal lParam As Long) As Long
                         
Private Ptr As Long

'Proxy-Funktion für Fibers
Public Sub FiberMainProc(ByRef Param As FiberData)

'ASM Proc generieren
If (Ptr = 0) Then

    Dim asm(0 To 19) As Byte
    
    asm(0) = &H50 'push (save) eax
    asm(1) = &H56 'push (save) esi
    asm(2) = &H8B 'mov eax, [esp+&H10] (Param)
    asm(3) = &H44
    asm(4) = &H24
    asm(5) = &H10
    asm(6) = &H8B 'mov esi,[esp+&H0c] (Address)
    asm(7) = &H74
    asm(8) = &H24
    asm(9) = &HC
    asm(10) = &H50 'push eax (Param)
    asm(11) = &HFF 'call esi (Address)
    asm(12) = &HD6
    asm(13) = &H5E 'pop (restore) esi
    asm(14) = &H58 'pop (restore) eax
    asm(15) = &HC2 'ret 16
    asm(16) = &H10
    asm(17) = 0
    
    Ptr = VirtualAlloc(ByVal 0&, 20, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
    Call CopyMemory(ByVal Ptr, asm(0), 20)
    
End If

'Kontrolle an eigentliche Funktion delegieren
Call CallWindowProc(Ptr, Param.UserProc, Param.UserParam, 0&, 0&)
 
'Funktion wurde beendet. Dieser Fiber darf mit seiner Beendigung nicht mehr scheduled werden
Call Fibers.DeleteFiber(Fibers.GetCurrentFiber())

'Diese Funktion darf nicht wieder verlassen werden. Da der Fiber sich nicht selbst löschen kann,
'muss so lange für einen Verbleib in dieser Funktion gesorgt werden, bis der Kontext gewechselt wurde und
'der Fiber gelöscht wird
Do
Loop

End Sub
'----------- Ende Modul "MFiber" alias MFiber.bas -----------
'--------- Anfang Klasse "CFiber" alias CFiber.cls  ---------
'Definiert, wieviele Fibers maximal verwendet werden können
Const MaxFibers As Long = 20

'Definiert die Zeitscheibenlänge eines Fibers
Const MaxDuration As Long = 20 'ms

'API Imports
Private Declare Sub GetSystemTimeAsFileTime Lib "kernel32.dll" (ByRef lpSystemTimeAsFileTime As Currency)

Private Declare Function W32CreateFiber Lib "kernel32.dll" Alias "CreateFiber" (ByVal dwStackSize As Long, ByVal lpStartAddress As Long, ByRef lpParameter As Any) As Long
Private Declare Sub W32DeleteFiber Lib "kernel32.dll" Alias "DeleteFiber" (ByVal lpFiber As Long)
Private Declare Sub W32SwitchToFiber Lib "kernel32.dll" Alias "SwitchToFiber" (ByVal lpFiber As Long)

Private Declare Function W32ConvertThreadToFiber Lib "kernel32.dll" Alias "ConvertThreadToFiber" (ByVal lpFiber As Long) As Long
Private Declare Function W32CConvertFiberToThread Lib "kernel32.dll" Alias "ConvertFiberToThread" (ByVal lpFiber As Long) As Long

Private Declare Sub W32Sleep Lib "kernel32.dll" Alias "Sleep" (ByVal dwMilliseconds As Long)

'Runtime Daten
Private InitVar As Long

Private Type DataType
    SecCount As Long
    FiberCount As Long
    CurrentFiber As Long
    NextFiberId As Long
    MaxFiberCount As Long
    TimeSliceDuration As Currency
    NextSchedule As Currency
    Fibers(0 To (MaxFibers - 1)) As FiberData
End Type

Private Data As DataType

Private Sub Class_Initialize()

'Fiber-Threading beim System anmelden und aktuellen Fiber als Fiber 0 speichern
Data.Fibers(0).Fiber = W32ConvertThreadToFiber(InitVar)
If (Data.Fibers(0).Fiber <> 0) Then

    Data.NextFiberId = 1
    
    Data.TimeSliceDuration = CCur(MaxDuration)
    Data.MaxFiberCount = MaxFibers
    
    Call GetSystemTimeAsFileTime(Data.Fibers(0).LastTimeSlice)
    
Else
    Call Err.Raise(2, , "can't convert thread to fiber")
    End
End If

End Sub

'Fiber-Threading beenden. Muss von Fiber 0(!) veranlasst werden. D.h. Klasse darf nur aus dem Kontext
'entladen werden, in dem sie auch geladen wurde!
Private Sub Class_Terminate()

Dim i As Long

'Alle Fibers aufräumen
For i = 1 To (MaxFibers - 1)
    If (Data.Fibers(i).Fiber <> 0) Then
        Call W32DeleteFiber(Data.Fibers(i).Fiber)
    End If
Next

End Sub

'Erzeugt einen neuen Fiber. Entry ist die Startfunktion, Param ein beliebiger Parameter. Es wird die ID des neuen
'Fibers zurückgegeben bzw. 0 im Fehlerfall
Public Function CreateFiber(ByVal Entry As Long, ByVal Param As Long) As Long

Dim i As Long
    
'Freien Slot suchen...
For i = 1 To (MaxFibers - 1)
    If (Data.Fibers(i).Fiber = 0) Then
    
        '... und Fiber sowie Daten zur Verwaltung anlegen
        Data.Fibers(i).Id = Data.NextFiberId
        Data.Fibers(i).UserProc = Entry
        Data.Fibers(i).UserParam = Param
        Data.Fibers(i).DeletionPending = False

        Data.Fibers(i).Fiber = W32CreateFiber(0, AddressOf FiberMainProc, Data.Fibers(i))

        CreateFiber = Data.Fibers(i).Id
        Data.NextFiberId = (Data.NextFiberId + 1)
        Data.FiberCount = (Data.FiberCount + 1)
        
        Exit For
    End If
Next
    
End Function

'Löscht einen Fiber. Kann nicht auf den Fiber 0 angewendet werden.
Public Sub DeleteFiber(ByVal Fiber As Long)

For i = 1 To (MaxFibers - 1)
    If (Data.Fibers(i).Fiber <> 0) Then
        If (Data.Fibers(i).Id = Fiber) Then
        
            If (Data.CurrentFiber <> Fiber) Then
                Call W32DeleteFiber(Data.Fibers(i).Fiber)
                Data.Fibers(i).Fiber = 0
                Data.FiberCount = (Data.FiberCount - 1)
            Else
                Data.Fibers(i).DeletionPending = True
                Data.NextSchedule = 0
                Call Schedule
            End If
            
            Exit For
        End If
    End If
Next

End Sub

'Wechselt den Kontext zum angegebenen Fiber
Public Sub SwitchToFiber(ByVal Fiber As Long)

Dim i As Long

For i = 0 To (MaxFibers - 1)
    If (Data.Fibers(i).Fiber <> 0) Then
        If (Data.Fibers(i).Id = Fiber) Then
                        
            Call GetSystemTimeAsFileTime(Data.Fibers(i).LastTimeSlice)
    
            'Nächsten Ablaufzeitpunkt berechnen
            Data.NextSchedule = (Data.Fibers(i).LastTimeSlice + Data.TimeSliceDuration)
    
            If (Data.Fibers(i).Id <> Data.CurrentFiber) Then
                Data.CurrentFiber = Data.Fibers(i).Id
                Call W32SwitchToFiber(Data.Fibers(i).Fiber)
            End If
                
            Exit For
        End If
    End If
Next

End Sub

'Setzt neue Dauer (Zeitscheibe) in ms bis zum Kontextwechsel
Public Sub SetTimeSliceDuration(ByVal Duration As Long)

Data.TimeSliceDuration = CCur(Duration)

End Sub

'Gibt die ID des aktiven Fiber zurück
Public Function GetCurrentFiber() As Long

GetCurrentFiber = Data.CurrentFiber

End Function

'Veranlasst bei Bedarf einen Kontextwechsel, Gibt true zurück, wenn eine Zeitscheibe abgelaufen
'ist und ein Scheduling veranlasst wird
Public Function Schedule() As Long

Dim i As Long, j As Long
Dim T As Currency

Call GetSystemTimeAsFileTime(T)

'Testen, ob aktuelle Zeitscheibe abgelaufen ist
If (Data.NextSchedule <= T) Then
    
    'Fiber suchen, dem am längsten keine Rechenzeit zugewiesen wurde
    For i = 0 To (MaxFibers - 1)
        If (Data.Fibers(i).SleepTimeout <= T) Then
            j = i
            Exit For
        End If
    Next
    
    If (i < MaxFibers) Then
        
        For i = 0 To (MaxFibers - 1)
            If (Data.Fibers(i).Fiber <> 0) Then
                If (Data.Fibers(i).Id <> Data.CurrentFiber) Then
                    If (Data.Fibers(i).DeletionPending = True) Then
                        Call DeleteFiber(Data.Fibers(i).Id)
                    Else
                        If (Data.Fibers(i).SleepTimeout < T) Then
                            If (Data.Fibers(i).LastTimeSlice <= Data.Fibers(j).LastTimeSlice) Then
                                j = i
                            End If
                        End If
                    End If
                End If
            End If
        Next
        
        'Zum gefundenen Fiber wechseln
        Call SwitchToFiber(Data.Fibers(j).Id)
            
        Schedule = True
        
    End If
    
End If

End Function

'Gibt die Anzahl der momentan existierenden Fiber zurück
Public Function GetFiberCount() As Long

GetFiberCount = Data.FiberCount

End Function

'Alle Fibers löschen.
Public Sub DeleteAllFibers()

Dim i As Long

For i = 1 To Data.MaxFiberCount
    If (Data.Fibers(i).Fiber <> 0) Then
        Call DeleteFiber(Data.Fibers(i).Id)
    End If
Next

End Sub

'Stellt sicher, dass alle Fiber aufgeräumt sind. Muss von Fiber 0 aufgerufen werden
Public Sub CleanUp()

Dim i As Long

If (Data.CurrentFiber = 0) Then
    
    For i = 1 To (MaxFibers - 1)
        If (Data.Fibers(i).Fiber <> 0) Then
            Call DeleteFiber(Data.Fibers(i).Id)
        End If
    Next
    
End If

End Sub

'Lässt den aktuellen Fiber für die angegebene Dauer in ms pausieren. Sleep(0) gibt die aktuelle Zeitscheibe auf
'und veranlasst ein unverzügliches wechseln zum nächsten Fiber
Public Sub Sleep(ByVal Duration As Long)

Dim i As Long

For i = 0 To (MaxFibers - 1)
    If (Data.Fibers(i).Fiber <> 0) Then
        If (Data.CurrentFiber = Data.Fibers(i).Id) Then
                    
            If (Data.FiberCount = 0) Then
                'Dies ist der einzige Fiber => nur warten
                Call W32Sleep(Duration)
            Else
                'Kontext wechseln
                
                Call GetSystemTimeAsFileTime(Data.Fibers(i).LastTimeSlice)
        
                'Nächster Ablaufzeitpunkt ist sofort
                Data.NextSchedule = 0
                
                Call GetSystemTimeAsFileTime(Data.Fibers(i).SleepTimeout)
                Data.Fibers(i).SleepTimeout = (Data.Fibers(i).SleepTimeout + Duration)
                
                Call Schedule
            End If
            
            Exit For
        
        End If
    End If
Next

End Sub

'---------- Ende Klasse "CFiber" alias CFiber.cls  ----------
'------------ Anfang Modul "Demo" alias Demo.bas ------------
'Demo-Funktion für Fiber 1
Public Sub FiberProc1(ByVal Param As Long)

Do
    'Eigentliche Aufgabe der Schleife durchführen
    Form1.Label2.Caption = CStr(CLng(Form1.Label2.Caption) + 1)
    DoEvents
    
    'Scheduler aufrufen; Fiber wird dadurch gewechselt, wenn die Zeitscheibendauer vorüber ist
    Fibers.Schedule
Loop

End Sub

'Demo Funktion für Fiber 2
Public Sub FiberProc2(ByVal Param As Long)

Dim i As Long

Do
    'Eigentliche Aufgabe der Schleife durchführen
    Form1.Label3.Caption = CStr(CLng(Form1.Label3.Caption) + 1)
    DoEvents
    
    'Scheduler aufrufen; Fiber wird dadurch gewechselt, wenn die Zeitscheibendauer vorüber ist
    Fibers.Schedule
    
    'Schleife nach 150 durchläufen verlassen
    i = i + 1
    If (i = 150) Then
        Exit Do
    End If
    
Loop

End Sub

'------------- Ende Modul "Demo" alias Demo.bas -------------
'-------------- Ende Projektdatei Projekt1.vbp --------------