freepascal.compiler/rtl/win32/tthread.inc

{ Thread management routines }

const
  CM_EXECPROC = $8FFF;
  CM_DESTROYWINDOW = $8FFE;

type
  PRaiseFrame = ^TRaiseFrame;
  TRaiseFrame = record
    NextRaise: PRaiseFrame;
    ExceptAddr: Pointer;
    ExceptObject: TObject;
    ExceptionRecord: pointer; {PExceptionRecord}
  end;

var
  ThreadWindow: HWND;
  ThreadCount: Integer;
  { event that happens when gui thread is done executing the method
}
  ExecuteEvent: PRtlEvent;
  { guard for synchronization variables }
  SynchronizeCritSect: systhrds.TRtlCriticalSection;
  { method to execute }
  SynchronizeMethod: TThreadMethod;
  { caught exception in gui thread, to be raised in calling thread }
  SynchronizeException: Exception;


function ThreadWndProc(Window: HWnd; AMessage:UInt; WParam : WParam; LParam: LParam): Longint; stdcall;

begin
  case AMessage of
    CM_EXECPROC:
      with TThread(lParam) do
      begin
        Result := 0;
        try
          FSynchronizeException := nil;
          FMethod;
        except
{          if RaiseList <> nil then
          begin
            FSynchronizeException := PRaiseFrame(RaiseList)^.ExceptObject;
            PRaiseFrame(RaiseList)^.ExceptObject := nil;
          end; }
        end;
      end;
    CM_DESTROYWINDOW:
      begin
        DestroyWindow(Window);
        Result := 0;
      end;
  else
    Result := DefWindowProc(Window, AMessage, wParam, lParam);
  end;
end;

const
  ThreadWindowClass: TWndClass = (
    style: 0;
    lpfnWndProc: nil;
    cbClsExtra: 0;
    cbWndExtra: 0;
    hInstance: 0;
    hIcon: 0;
    hCursor: 0;
    hbrBackground: 0;
    lpszMenuName: nil;
    lpszClassName: 'TThreadWindow');

procedure AddThread;

  function AllocateWindow: HWND;
  var
    TempClass: TWndClass;
    ClassRegistered: Boolean;
  begin
    ThreadWindowClass.hInstance := HInstance;
    ThreadWindowClass.lpfnWndProc:=WndProc(@ThreadWndProc);
    ClassRegistered := GetClassInfo(HInstance, ThreadWindowClass.lpszClassName,
      @TempClass);
    if not ClassRegistered or (TempClass.lpfnWndProc <> WndProc(@ThreadWndProc)) then
    begin
      if ClassRegistered then
        Windows.UnregisterClass(ThreadWindowClass.lpszClassName, HInstance);
      Windows.RegisterClass(ThreadWindowClass);
    end;
    Result := CreateWindow(ThreadWindowClass.lpszClassName, '', 0,
      0, 0, 0, 0, 0, 0, HInstance, nil);
  end;

begin
  if ThreadCount = 0 then
    ThreadWindow := AllocateWindow;
  Inc(ThreadCount);
end;

procedure RemoveThread;
begin
  Dec(ThreadCount);
  if ThreadCount = 0 then
    PostMessage(ThreadWindow, CM_DESTROYWINDOW, 0, 0);
end;

{ TThread }

function ThreadProc(ThreadObjPtr: Pointer): Integer;
var
  FreeThread: Boolean;
  Thread: TThread absolute ThreadObjPtr;
begin
  try
    Thread.Execute;
  except
    Thread.FFatalException := TObject(AcquireExceptionObject);
  end;
  FreeThread := Thread.FFreeOnTerminate;
  Result := Thread.FReturnValue;
  Thread.FFinished := True;
  Thread.DoTerminate;
  if FreeThread then Thread.Free;
end;

constructor TThread.Create(CreateSuspended: Boolean);
var
  Flags: Integer;
begin
  inherited Create;
  AddThread;
  FSuspended := CreateSuspended;
  Flags := 0;
  if CreateSuspended then Flags := CREATE_SUSPENDED;
  FHandle := BeginThread(nil, 0, @ThreadProc, pointer(self), Flags, FThreadID);
  FFatalException := nil;
end;


destructor TThread.Destroy;
begin
  if not FFinished and not Suspended then
  begin
    Terminate;
    WaitFor;
  end;
  if FHandle <> 0 then CloseHandle(FHandle);
  FFatalException.Free;
  FFatalException := nil;
  inherited Destroy;
  RemoveThread;
end;

procedure TThread.CallOnTerminate;
begin
  FOnTerminate(Self);
end;

procedure TThread.DoTerminate;
begin
  if Assigned(FOnTerminate) then
    Synchronize(@CallOnTerminate);
end;

const
  Priorities: array [TThreadPriority] of Integer =
   (THREAD_PRIORITY_IDLE, THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_BELOW_NORMAL,
    THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_ABOVE_NORMAL,
    THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_TIME_CRITICAL);

function TThread.GetPriority: TThreadPriority;
var
  P: Integer;
  I: TThreadPriority;
begin
  P := GetThreadPriority(FHandle);
  Result := tpNormal;
  for I := Low(TThreadPriority) to High(TThreadPriority) do
    if Priorities[I] = P then Result := I;
end;

procedure TThread.SetPriority(Value: TThreadPriority);
begin
  SetThreadPriority(FHandle, Priorities[Value]);
end;

{ old implementation? :
procedure TThread.Synchronize(Method: TThreadMethod);
begin
  FSynchronizeException := nil;
  FMethod := Method;
  SendMessage(ThreadWindow, CM_EXECPROC, 0, Longint(Self));
  if Assigned(FSynchronizeException) then raise FSynchronizeException;
end;
}

procedure TThread.Synchronize(Method: TThreadMethod);
var
  LocalSyncException: Exception;
begin
  if SynchronizeMethodProc = nil then
    { raise some error? }
    exit;

  systhrds.EnterCriticalSection(SynchronizeCritSect);
  SynchronizeMethod := Method;
  SynchronizeException := nil;
  SynchronizeMethodProc;
  // wait infinitely
  RtlEventWaitFor(ExecuteEvent);
  SynchronizeMethod := nil;
  LocalSyncException := SynchronizeException;
  systhrds.LeaveCriticalSection(SynchronizeCritSect);
  if LocalSyncException <> nil then
    raise LocalSyncException;
end;

procedure CheckSynchronize;
  { assumes being called from GUI thread }
begin
  if SynchronizeMethod = nil then
    exit;

  try
    SynchronizeMethod;
  except
    SynchronizeException := Exception(AcquireExceptionObject);
  end;
  RtlEventSetEvent(ExecuteEvent);
end;

procedure TThread.SetSuspended(Value: Boolean);
begin
  if Value <> FSuspended then
    if Value then
      Suspend else
      Resume;
end;

procedure TThread.Suspend;
begin
  FSuspended := True;
  SuspendThread(FHandle);
end;

procedure TThread.Resume;
begin
  if ResumeThread(FHandle) = 1 then FSuspended := False;
end;

procedure TThread.Terminate;
begin
  FTerminated := True;
end;

function TThread.WaitFor: Integer;
var
  Msg: TMsg;
begin
  if GetCurrentThreadID = MainThreadID then
    while MsgWaitForMultipleObjects(1, FHandle, False, INFINITE, QS_SENDMESSAGE) = WAIT_OBJECT_0 + 1 do
      PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE)
  else
    WaitForSingleObject(ulong(FHandle), INFINITE);
  GetExitCodeThread(FHandle, DWord(Result));
end;
{
  $Log$
  Revision 1.4  2004-12-26 13:46:45  peter
    * tthread uses systhrds

  Revision 1.3  2004/12/23 09:42:42  marco
   * first tthread.synchronize support (merged neli's patches)

  Revision 1.2  2004/01/29 16:58:28  marco
   * threadproc is passed to OS and must be stdcall;

  Revision 1.1  2003/10/06 21:01:07  peter
    * moved classes unit to rtl

  Revision 1.8  2003/10/06 17:06:55  florian
    * applied Johannes Berg's patch for exception handling in threads

  Revision 1.7  2003/04/23 11:35:30  peter
    * wndproc definition fix

  Revision 1.6  2002/09/07 15:15:29  peter
    * old logs removed and tabs fixed

}