591 lines
17 KiB
Plaintext
591 lines
17 KiB
Plaintext
{
|
|
$Project$
|
|
$Workfile$
|
|
$Revision$
|
|
$DateUTC$
|
|
$Id$
|
|
|
|
This file is part of the Indy (Internet Direct) project, and is offered
|
|
under the dual-licensing agreement described on the Indy website.
|
|
(http://www.indyproject.org/)
|
|
|
|
Copyright:
|
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
|
}
|
|
{
|
|
$Log$
|
|
}
|
|
{
|
|
Rev 1.3 6/11/2004 8:39:48 AM DSiders
|
|
Added "Do not Localize" comments.
|
|
|
|
Rev 1.2 2004.04.22 11:45:16 PM czhower
|
|
Bug fixes
|
|
|
|
Rev 1.1 2004.02.09 9:16:34 PM czhower
|
|
Updated to compile and match lib changes.
|
|
|
|
Rev 1.0 2004.02.03 12:38:48 AM czhower
|
|
Move
|
|
|
|
Rev 1.8 2003.10.24 1:00:04 PM czhower
|
|
Name change
|
|
|
|
Rev 1.7 2003.10.21 12:19:20 AM czhower
|
|
TIdTask support and fiber bug fixes.
|
|
|
|
Rev 1.6 2003.10.19 2:50:38 PM czhower
|
|
Fiber cleanup
|
|
|
|
Rev 1.5 2003.10.19 1:04:26 PM czhower
|
|
Updates
|
|
|
|
Rev 1.3 2003.10.11 5:43:12 PM czhower
|
|
Chained servers now functional.
|
|
|
|
Rev 1.2 2003.09.19 10:09:38 PM czhower
|
|
Next stage of fiber support in servers.
|
|
|
|
Rev 1.1 2003.09.19 3:01:34 PM czhower
|
|
Changed to emulate IdThreads Run behaviour
|
|
|
|
Rev 1.0 8/16/2003 11:09:14 AM JPMugaas
|
|
Moved from Indy Core dir as part of package reorg
|
|
|
|
Rev 1.25 7/2/2003 2:06:40 PM BGooijen
|
|
changed IdSupportsFibers to TIdFiberBase.HaveFiberSupport
|
|
|
|
Rev 1.24 7/1/2003 8:34:14 PM BGooijen
|
|
Added function IdSupportsFibers
|
|
Fiber-functions are now loaded on runtime
|
|
|
|
Rev 1.23 2003.06.30 7:33:50 PM czhower
|
|
Fix to exception handling.
|
|
|
|
Rev 1.22 2003.06.30 6:52:20 PM czhower
|
|
Exposed FiberWeaver has a property.
|
|
|
|
Rev 1.21 2003.06.03 11:05:02 PM czhower
|
|
Modified ProcessInThisFiber to support error flag return.
|
|
|
|
Rev 1.20 2003.06.03 8:01:38 PM czhower
|
|
Completed fiber exception handling.
|
|
|
|
Rev 1.19 2003.05.27 10:27:08 AM czhower
|
|
Put back original exception handling.
|
|
|
|
Rev 1.18 5/16/2003 3:48:24 PM BGooijen
|
|
Added FreeOnTerminate
|
|
|
|
Rev 1.17 4/17/2003 7:40:00 PM BGooijen
|
|
Added AAutoStart for fibers
|
|
|
|
Rev 1.16 2003.04.17 7:44:56 PM czhower
|
|
|
|
Rev 1.15 2003.04.14 10:54:08 AM czhower
|
|
Fiber specific exceptions
|
|
|
|
Rev 1.14 2003.04.12 11:53:56 PM czhower
|
|
Added DoExecute
|
|
|
|
Rev 1.13 4/11/2003 1:46:58 PM BGooijen
|
|
added ProcessInThisFiber and WaitForFibers to TIdFiberWeaverBase
|
|
|
|
Rev 1.12 2003.04.10 11:21:42 PM czhower
|
|
Yield support
|
|
|
|
Rev 1.9 2003.03.27 1:29:14 AM czhower
|
|
Exception frame swapping.
|
|
|
|
Rev 1.7 3/22/2003 09:45:28 PM JPMugaas
|
|
Now should compile under D4.
|
|
|
|
Rev 1.6 2003.03.13 1:25:18 PM czhower
|
|
Moved check for parent fiber to SwitchTo
|
|
|
|
Rev 1.5 3/13/2003 10:18:12 AM BGooijen
|
|
Server side fibers, bug fixes
|
|
|
|
Rev 1.4 2003.02.18 1:25:04 PM czhower
|
|
Added exception if user tries to SwitchTo a completed fiber.
|
|
|
|
Rev 1.3 2003.01.17 2:32:12 PM czhower
|
|
|
|
Rev 1.2 1-1-2003 16:25:10 BGooijen
|
|
The property ParentFiber can now be written to
|
|
Added class function TIdFiberBase.GetCurrentFiberBase, which returns the
|
|
current TIdFiber
|
|
|
|
Rev 1.1 12-28-2002 12:01:18 BGooijen
|
|
Made a public read only property: ParentFiber
|
|
|
|
Rev 1.0 11/13/2002 08:44:18 AM JPMugaas
|
|
}
|
|
|
|
unit IdFiber;
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes,
|
|
IdThreadSafe, IdBaseComponent, IdYarn, IdTask,
|
|
SyncObjs, SysUtils,
|
|
Windows;
|
|
|
|
type
|
|
// TIdFiberBase is the base for both fiber types and contains
|
|
// methods that are common to both and defines the general interface. All
|
|
// references to fibers should generally use this base type.
|
|
TIdFiberBase = class(TObject)
|
|
protected
|
|
FHandle: Pointer;
|
|
FPriorFiber: TIdFiberBase;
|
|
FName: string;
|
|
FRaiseList: Pointer;
|
|
// No descendants should ever call this. Its internal only
|
|
// and should only be called after destruction or after the RaiseList has
|
|
// been saved
|
|
procedure SwitchToMeFrom(
|
|
AFromFiber: TIdFiberBase
|
|
);
|
|
public
|
|
constructor Create; reintroduce; virtual;
|
|
procedure CheckRunnable; virtual;
|
|
class function HaveFiberSupport: Boolean;
|
|
procedure SwitchTo(AFiber: TIdFiberBase);
|
|
//
|
|
property Name: string read FName write FName;
|
|
property PriorFiber: TIdFiberBase read FPriorFiber;
|
|
property Handle: Pointer read FHandle;
|
|
end;
|
|
|
|
TIdFiber = class;
|
|
TIdFiberRelinquishEvent = procedure(
|
|
ASender: TIdFiber;
|
|
AReschedule: Boolean
|
|
) of object;
|
|
|
|
// TIdConvertedFiber is used to represent thread that have been converted to
|
|
// fibers
|
|
TIdConvertedFiber = class(TIdFiberBase)
|
|
public
|
|
constructor Create; override;
|
|
end;
|
|
|
|
// TIdFiber is the general purpose fiber. To implement fibers descend from
|
|
// TIdFiber.
|
|
TIdFiber = class(TIdFiberBase)
|
|
protected
|
|
FFatalException: Exception;
|
|
FFatalExceptionOccurred: Boolean;
|
|
FFinished: TIdThreadSafeBoolean;
|
|
FFreeFatalException: Boolean;
|
|
FFreeFiber: Boolean;
|
|
FLoop: Boolean;
|
|
FOnRelinquish: TIdFiberRelinquishEvent;
|
|
FParentFiber: TIdFiberBase;
|
|
FStarted: TIdThreadSafeBoolean;
|
|
FStopped: TIdThreadSafeBoolean;
|
|
FYarn: TIdYarn;
|
|
//
|
|
procedure AfterRun; virtual; //not abstract - otherwise it is required
|
|
procedure BeforeRun; virtual; //not abstract - otherwise it is required
|
|
function GetFinished: Boolean;
|
|
function GetStarted: Boolean;
|
|
function GetStopped: Boolean;
|
|
procedure Execute;
|
|
procedure Run; virtual; abstract;
|
|
procedure SwitchToParent;
|
|
public
|
|
procedure CheckRunnable; override;
|
|
constructor Create(
|
|
AParentFiber: TIdFiberBase = nil;
|
|
ALoop: Boolean = False;
|
|
AStackSize: Integer = 0);
|
|
reintroduce;
|
|
destructor Destroy;
|
|
override;
|
|
procedure RaiseFatalException;
|
|
// Relinquish is used when the fiber is stuck and cannot usefully do
|
|
// anything. It will be removed from scheduling until something reschedules
|
|
// it. This is different than yield.
|
|
//
|
|
// Relinquish is used with FiberWeavers to tell them that the fiber is done
|
|
// or blocked. Something external such as more work, or completion of a task
|
|
// must reschedule the fiber with the fiber weaver.
|
|
procedure Relinquish;
|
|
procedure SetRelinquishHandler(AValue: TIdFiberRelinquishEvent);
|
|
procedure Stop; virtual;
|
|
// Gives up execution time and tells scheduler to process next available
|
|
// fiber.
|
|
// For manual fibers (no weaver) relinquish is called
|
|
// For woven fibers, the fiber is rescheduled and relinquished.
|
|
procedure Yield;
|
|
//
|
|
property FatalExceptionOccurred: Boolean read FFatalExceptionOccurred;
|
|
property Finished: Boolean read GetFinished;
|
|
property Loop: Boolean read FLoop write FLoop;
|
|
property Started: Boolean read GetStarted;
|
|
property Stopped: Boolean read GetStopped;
|
|
property ParentFiber: TIdFiberBase read FParentFiber write FParentFiber;
|
|
property Yarn: TIdYarn read FYarn write FYarn;
|
|
end;
|
|
|
|
TIdFiberWithTask = class(TIdFiber)
|
|
protected
|
|
FTask: TIdTask;
|
|
public
|
|
procedure AfterRun; override;
|
|
procedure BeforeRun; override;
|
|
// Defaults because a bit crazy to create a non looped task
|
|
constructor Create(
|
|
AParentFiber: TIdFiberBase = nil;
|
|
ATask: TIdTask = nil;
|
|
AName: string = '';
|
|
AStackSize: Integer = 0
|
|
); reintroduce;
|
|
destructor Destroy;
|
|
override;
|
|
procedure Run;
|
|
override;
|
|
//
|
|
// Must be writeable because tasks are often created after thread or
|
|
// thread is pooled
|
|
property Task: TIdTask read FTask write FTask;
|
|
end;
|
|
|
|
|
|
implementation
|
|
|
|
uses
|
|
IdGlobal, IdResourceStringsCore, IdExceptionCore, IdException;
|
|
|
|
var
|
|
SwitchToFiber: function(lpFiber: Pointer): BOOL; stdcall = nil;
|
|
CreateFiber: function(dwStackSize: DWORD; lpStartAddress: TFNFiberStartRoutine;
|
|
lpParameter: Pointer): BOOL; stdcall=nil;
|
|
DeleteFiber: function (lpFiber: Pointer): BOOL; stdcall = nil;
|
|
ConvertThreadToFiber: function (lpParameter: Pointer): BOOL; stdcall = nil;
|
|
|
|
procedure LoadFiberFunctions;
|
|
var
|
|
LKernel32Handle: THandle;
|
|
begin
|
|
if TIdFiberBase.HaveFiberSupport then begin
|
|
LKernel32Handle := GetModuleHandle(kernel32);
|
|
SwitchToFiber := Getprocaddress(LKernel32Handle,'SwitchToFiber'); {do not localize}
|
|
CreateFiber := Getprocaddress(LKernel32Handle,'CreateFiber'); {do not localize}
|
|
DeleteFiber := Getprocaddress(LKernel32Handle,'DeleteFiber'); {do not localize}
|
|
ConvertThreadToFiber := Getprocaddress(LKernel32Handle,'ConvertThreadToFiber'); {do not localize}
|
|
if Assigned(@SwitchToFiber) and
|
|
Assigned(@CreateFiber) and
|
|
Assigned(@DeleteFiber) and
|
|
Assigned(@ConvertThreadToFiber) then begin
|
|
Exit;
|
|
end else begin
|
|
SwitchToFiber := nil;
|
|
CreateFiber := nil;
|
|
DeleteFiber := nil;
|
|
ConvertThreadToFiber := nil;
|
|
end;
|
|
end;
|
|
raise EIdFibersNotSupported.Create(RSFibersNotSupported);
|
|
end;
|
|
|
|
procedure FiberFunc(AFiber: TIdFiber); stdcall;
|
|
var
|
|
LParentFiber: TIdFiberBase;
|
|
begin
|
|
with AFiber do begin
|
|
Execute;
|
|
LParentFiber := ParentFiber;
|
|
end;
|
|
// Threads converted from Fibers have no parent. Also use may specify
|
|
// nil if they want to control exit manually.
|
|
//
|
|
// We must do this last because with schedulers fibers get switched away
|
|
// at this last point and not rescheduled. We do this outside the
|
|
// execute as the fiber will likely be freed from somewhere else
|
|
if LParentFiber <> nil then begin
|
|
LParentFiber.SwitchToMeFrom(AFiber);
|
|
end;
|
|
end;
|
|
|
|
{ TIdFiber }
|
|
|
|
procedure TIdFiber.AfterRun;
|
|
begin
|
|
end;
|
|
|
|
procedure TIdFiber.BeforeRun;
|
|
begin
|
|
end;
|
|
|
|
procedure TIdFiber.CheckRunnable;
|
|
begin
|
|
inherited;
|
|
EIdFiberFinished.IfTrue(Finished, 'Fiber is finished.'); {do not localize}
|
|
EIdFiber.IfTrue((ParentFiber = nil) and (Assigned(FOnRelinquish) = False)
|
|
, 'No parent fiber or fiber weaver specified.'); {do not localize}
|
|
end;
|
|
|
|
constructor TIdFiber.Create(
|
|
AParentFiber: TIdFiberBase;
|
|
ALoop: Boolean;
|
|
AStackSize: Integer
|
|
);
|
|
begin
|
|
inherited Create;
|
|
FFinished := TIdThreadSafeBoolean.Create;
|
|
FStarted := TIdThreadSafeBoolean.Create;
|
|
FStopped := TIdThreadSafeBoolean.Create;
|
|
FFreeFiber := True;
|
|
FLoop := ALoop;
|
|
FParentFiber := AParentFiber;
|
|
// Create Fiber
|
|
FHandle := Pointer(CreateFiber(AStackSize, @FiberFunc, Self));
|
|
Win32Check(LongBool(FHandle));
|
|
end;
|
|
|
|
destructor TIdFiber.Destroy;
|
|
begin
|
|
EIdException.IfTrue(Started and (Finished = False), 'Fiber not finished.'); {do not localize}
|
|
// Threads converted from Fibers will have nil parents and if we call
|
|
// DeleteFiber it will exit the whole thread.
|
|
if FFreeFiber then begin
|
|
// Must never call from self. If so ExitThread is called
|
|
// Because of this FreeOnTerminate cannot be suported because a fiber
|
|
// cannot delete itself, and we never know where a fiber will go for sure
|
|
// when it is done. It can be done that the next fiber deletes it, but
|
|
// there are catches here too. Because of this I have made it the
|
|
// responsibility of the user (manual) or the scheduler (optional).
|
|
Win32Check(DeleteFiber(FHandle));
|
|
end;
|
|
FreeAndNil(FYarn);
|
|
FreeAndNil(FFinished);
|
|
FreeAndNil(FStarted);
|
|
FreeAndNil(FStopped);
|
|
// Kudzu:
|
|
// Docs say to call ReleaseException, but its empty. But it appears that since
|
|
// we are taking the exception and taking it from the raise list, that instead
|
|
// what we need to do is call .Free on the exception instead and that the docs
|
|
// are wrong. Need to run through a memory checker to verify the behaviour.
|
|
//
|
|
// Normally the except block frees the exception object, but we are stealing
|
|
// it out fo the list, so it does not free it.
|
|
//
|
|
// Ive looked into TThread and this is what it does as well, so big surprise
|
|
// that the docs are wrong.
|
|
//
|
|
// Update: We only free it if we dont reraise the exception. If we reraise it
|
|
// the fiber may be freed in a finally, and thus when the exception is handled
|
|
// again an AV or other will occur because the exception has been freed.
|
|
// When it is reraised, it is added back into the exception list and the
|
|
// VCL will free it as part of the final except block.
|
|
//
|
|
if FFreeFatalException then begin
|
|
FreeAndNil(FFatalException);
|
|
end;
|
|
//
|
|
inherited;
|
|
end;
|
|
|
|
procedure TIdFiber.Execute;
|
|
begin
|
|
try
|
|
try
|
|
BeforeRun; try
|
|
// This can be combined, but then it checks loop each run and its not
|
|
// valid to toggle it after run has started and therefore adds an
|
|
// unnecessary check
|
|
if Loop then begin
|
|
while not Stopped do begin
|
|
Run;
|
|
// If Weaver, this will let the weaver reschedule.
|
|
// If manual it will switch back to parent to let it handle it.
|
|
// If stopped just run through so it can clean up and exit
|
|
if not Stopped then begin
|
|
Yield;
|
|
end;
|
|
end;
|
|
end else begin
|
|
Run;
|
|
end;
|
|
finally AfterRun; end;
|
|
except FFatalException := AcquireExceptionObject; end;
|
|
if FFatalException <> nil then begin
|
|
FFatalExceptionOccurred := True;
|
|
FFreeFatalException := True;
|
|
end;
|
|
finally FFinished.Value := True; end;
|
|
end;
|
|
|
|
function TIdFiber.GetFinished: Boolean;
|
|
begin
|
|
Result := FFinished.Value;
|
|
end;
|
|
|
|
function TIdFiber.GetStarted: Boolean;
|
|
begin
|
|
Result := FStarted.Value;
|
|
end;
|
|
|
|
function TIdFiber.GetStopped: Boolean;
|
|
begin
|
|
Result := FStopped.Value;
|
|
end;
|
|
|
|
procedure TIdFiber.RaiseFatalException;
|
|
begin
|
|
if FatalExceptionOccurred then begin
|
|
FFreeFatalException := False;
|
|
raise FFatalException;
|
|
end;
|
|
end;
|
|
|
|
procedure TIdFiber.Stop;
|
|
begin
|
|
FStopped.Value := True;
|
|
end;
|
|
|
|
procedure TIdFiber.SwitchToParent;
|
|
begin
|
|
EIdException.IfNotAssigned(FParentFiber, 'No parent fiber to switch to.'); {do not localize}
|
|
SwitchTo(FParentFiber);
|
|
end;
|
|
|
|
procedure TIdFiber.Relinquish;
|
|
begin
|
|
if Assigned(FOnRelinquish) then begin
|
|
FOnRelinquish(Self, False);
|
|
end else begin
|
|
SwitchToParent;
|
|
end;
|
|
end;
|
|
|
|
procedure TIdFiber.Yield;
|
|
begin
|
|
// If manual fiber, yield is same as relinquish
|
|
if Assigned(FOnRelinquish) then begin
|
|
FOnRelinquish(Self, True);
|
|
end else begin
|
|
SwitchToParent;
|
|
end;
|
|
end;
|
|
|
|
procedure TIdFiber.SetRelinquishHandler(AValue: TIdFiberRelinquishEvent);
|
|
begin
|
|
FOnRelinquish := AValue;
|
|
end;
|
|
|
|
{ TIdConvertedFiber }
|
|
|
|
constructor TIdConvertedFiber.Create;
|
|
begin
|
|
inherited;
|
|
FHandle := Pointer(ConvertThreadToFiber(Self));
|
|
end;
|
|
|
|
{ TIdFiberBase }
|
|
|
|
constructor TIdFiberBase.Create;
|
|
begin
|
|
inherited;
|
|
if not Assigned(@CreateFiber) then begin
|
|
LoadFiberFunctions;
|
|
end;
|
|
end;
|
|
|
|
procedure TIdFiberBase.CheckRunnable;
|
|
begin
|
|
end;
|
|
|
|
class function TIdFiberBase.HaveFiberSupport:boolean;
|
|
begin
|
|
Result := IndyWindowsPlatform = VER_PLATFORM_WIN32_NT;
|
|
end;
|
|
|
|
procedure TIdFiberBase.SwitchTo(AFiber: TIdFiberBase);
|
|
begin
|
|
//Kudzu
|
|
// Be VERY careful in this section. This section takes care of Delphi's
|
|
// exception handling mechanism.
|
|
//
|
|
// This section swaps out the exception frames for each fiber so that
|
|
// exceptions are handled properly, preserved between switches, and across
|
|
// threads.
|
|
//
|
|
// Notes:
|
|
// -Only works on Windows, but we dont support fibers on Kylix right now
|
|
// anyways
|
|
// -Developer MUST use our fibers and not call Fiber API calls directly.
|
|
// -May not work on C++ Builder at this time.
|
|
// -May not work on older Delphi editions at this time.
|
|
// -If the user calls this method and the fiber is not the current fiber, will
|
|
// be problems. Maybe lock against thread ID and check that.
|
|
//
|
|
// This could be extended to make ThreadVars "FiberVars" by swaping out the
|
|
// TLS entry. I may make this an option in the future.
|
|
// This would also take care of the exception stack by itself and may be
|
|
// more portable to Linux, CB and older versions of Delphi. Will check later.
|
|
//
|
|
//
|
|
// Save raise list for current fiber
|
|
FRaiseList := RaiseList;
|
|
AFiber.SwitchToMeFrom(Self);
|
|
end;
|
|
|
|
procedure TIdFiberBase.SwitchToMeFrom(
|
|
AFromFiber: TIdFiberBase
|
|
);
|
|
begin
|
|
// See if we can run the fiber. If not it will raise an exception.
|
|
CheckRunnable;
|
|
FPriorFiber := AFromFiber;
|
|
// Restore raise list
|
|
SetRaiseList(FRaiseList);
|
|
// Switch to the actual fiber
|
|
SwitchToFiber(Handle);
|
|
end;
|
|
|
|
{ TIdFiberWithTask }
|
|
|
|
procedure TIdFiberWithTask.AfterRun;
|
|
begin
|
|
FTask.DoAfterRun;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TIdFiberWithTask.BeforeRun;
|
|
begin
|
|
inherited;
|
|
FTask.DoBeforeRun;
|
|
end;
|
|
|
|
constructor TIdFiberWithTask.Create(
|
|
AParentFiber: TIdFiberBase = nil;
|
|
ATask: TIdTask = nil;
|
|
AName: string = '';
|
|
AStackSize: Integer = 0
|
|
);
|
|
begin
|
|
inherited Create(AParentFiber, True, AStackSize);
|
|
FTask := ATask;
|
|
end;
|
|
|
|
destructor TIdFiberWithTask.Destroy;
|
|
begin
|
|
FreeAndNil(FTask);
|
|
inherited;
|
|
end;
|
|
|
|
procedure TIdFiberWithTask.Run;
|
|
begin
|
|
if not FTask.DoRun then begin
|
|
Stop;
|
|
end;
|
|
end;
|
|
|
|
end.
|
|
|