Thready v Delphi

aneb poněkud obecný popis, na co je třeba dát pozor při práci s thready.

Obsah:


Co je Thread?


Thread - česky někdy vlákno - je funkce, která se vykonává paralelně s jinými thready programu. Každý program má nejméně jeden thread, tzv. primární. (v Delphi je jeho identifikátor v proměnné MainThreadId v unitě System.)

Po návratu z funkce threadu tento thread končí.
Po návratu z hlavního threadu končí celý process.

Na jednoprocesorovém počítači nejsou thready vykonávány skutečně paralelně, ale jsou přepínány systémem v přerušení hardwarového timeru s frekvencí cca 10ms, a rovněž tehdy, když thread začne na něco "čekat" (což je o dost lepší).

Přerušení timeru může ovšem přijít mezi jakýmikoli dvěma instrukcemi kódu. Nelze to přesně "odzkoušet", protože je to značně náhodné...


v optimálním případě všechny thready všech procesů na něco čekají (např. WaitMessage nebo GetMessage, WaitForSingleObject, ReadFile, atd...) a většinu procesorového času spotřebuje idle-thread v System idle processes.
Thread, který na nic nečeká a dlouho počítá, by si zasloužil sníženou prioritu...

Pro další informace, jak windows řeší multi-tasking, viz téma "Processes and Threads" v manuálu Win32.hlp, dodávaném s Delphi... (a pokračování klávesou > tečka/větší)

Re-entrantnost

Než můžete z funkce threadu cokoli použít, je třeba se přesvědčit, do jaké míry je ta věc "re-entrantní" - nebo-li jestli může být najednou vyvolána z více threadů...

Rozdělení, na co se thready hodí a na co ne:

(Tento seznam rozhodně není kompletní...)

Thready se hodí:
Thready se nehodí na:

Na co je v threadu třeba dát pozor:

A další poznámky:

Identifikátor a handle threadu

Každý thread má identifikátor (nazývaný ThreadId), který je unikátní v celém systému, dokud je thread spuštěn.

Handle threadu je vrácena funkcí CreateThread i BeginThread, objekt TThread ji má v property Handle.

Pomocí handle threadu lze: Handle threadu je možné "rozmnožit" voláním DuplicateHandle, ale není možné ji nijak (žádnou dokumentovanou funkcí na WinNT, žádnou známou funkcí na Win9x) otevřít zvenčí (z bezpečnostních důvodů).
(Leckdo se na to spoléhá, ale zvláště anti-virový program by se spolehnout neměl a měl by si opatřit thready security descriptorem!)

Funkce GetCurrentThread vrací "pseudo-handle" threadu s hodnotou -2, obdobně jako GetCurrentProcess vrací "pseudo-handle" procesu s hodnotou -1.
Skutečný handle, který by bylo možné použít i z jiného threadu, lze z tohoto "pseudo-handle" vytvořit funkcí DuplicateHandle...


TLS a Threadvar

TLS - nebo-li Thread Local Storage - je malá oblast, kterou má každý thread svoji. Systém "garantuje" 64 slotů, ovšem každá druhá DLL alespoň jeden používá...

V programech v Delphi je místo toho k dispozici klíčové slovo threadvar.
Obvykle je tedy v TLS slotu jen pointer na alokované array všech threadvar v daném modulu (EXE nebo DLL).

Přístup k takové proměnné kompilátor řeší voláním funkce GetTls v unitě SysInit , takže při vícenásobném použití je lepší si hodnotu threadvar jednou vyzvednout před vstupem do cyklu - nebo aspoň pointer na ni operátorem @ ...

Threadvar se použije pro globální proměnné, které mají být v každém threadu samostatné.

Obsah takové threadvar je inicializován 00 v každém threadu a není nijak uvolňován, takže takto nelze skladovat např. string nebo objekt...
Celé pole všech threadvar je alokováno nejpozději při prvním požadavku na GetTLS, a uvolněno při skončení threadu, zřejmě ale jen pokud: I pokud Váš kód nepoužívá threadvar, unita System ano - takže EXE i všechny DLL napsané v Delphi, pokud nejsou linkovány s bpl, (a většinou zřejmě i DLL z MSC) mají jeden TLS slot a alokovanou paměť pro svůj blok threadvar pro každý thread...

Co všechno má každý thread svého:


Thready ve funkci

Pro jednoduché operace stačí nadefinovat jednu funkci, která se vykoná a skončí - např. pro zkopírování souboru nebo spuštění externího programu bez čekání, než poprvé zavolá GetMessage...

Funkce threadu dostane 1 parametr - obvykle Pointer na větší strukturu.
Návratová hodnota z funkce threadu je jeho výsledným kódem, který lze vyzvednout voláním GetExitCodeThread.

Thread je vytvořen voláním funkcí BeginThread v unitě System nebo API funkcí CreateThread.
Rozdíl je drobný ale podstatný: Funkci threadu je nutné obalit try..except end; handlerem, který odchytí jakoukoli exception v threadu.
Pokud totiž thread způsobí exception, celý process neslavně skončí s návodem na odeslání do MicroSoftu, o což se postará funkce UnhandledExceptionFilter()...

Record v parametru funkce ovšem nesmí ukazovat na zásobník (lokální proměnné) funkce, která thread spouští. Thread je spuštěn až nějakou dobu po vytvoření, a zejména až poté, co původní thread začne na něco čekat - např. v hlavním bloku aplikace na WaitMessage...

Ukázka:

type
  PMyThreadParams=^TMyThreadParams;
  TMyThreadParams=record
    FileName:      string;
    CmdShow:       integer;
  end;
  
function ExecFileThreadProc(Param: Pointer): Longint;
var ptp: PMyThreadParams;
begin
  try
    try
      ptp:=Param;
      //
      ShellExecute(0,'open',PChar(ptp.FileName),nil,nil,ptp.CmdShow);
      //
    finally
      ptp:=Param;
      Finalize(ptp^);
      FreeMem(ptp);
    end;
  except
    // main thread catcher...
  end;
  //
  Result:=0;
end;

function SpustSoubor(const FileName: string; CmdShow: integer): Boolean;
var ptp: PMyThreadParams;
    thh: THandle;
    thid: Cardinal;
begin
  // Alokace parametrů pro thread:
  ptp:=AllocMem(SizeOf(TMyThreadParams));
  ptp.FileName:=FileName;
  ptp.CmdShow:=CmdShow;
  // Spuštění threadu:
  thh:=BeginThread(nil,0,@ExecFileThreadProc,ptp,0,thid);
  // Zavření handle threadu:
  if (thh<>0) then begin
    // Thread byl spuštěn...
    CloseHandle(thh);
    //
    Result:=True;
    //
  end else begin
    // Systém je přetížen?
    Finalize(ptp^);
    FreeMem(ptp);
    //
    Result:=False;
  end;
end;

Kdyby ovšem v parametrech threadu bylo např. i jeho ID nebo Handle, získané až po návratu z BeginThread, pak se v předposledním parametru zadá CREATE_SUSPENDED, a po dovyplnění parametru se zavolá funkce ResumeThread pro spuštění threadu...
Tato technika se obzvláště hodí pro nastavení různých property v objektovém TThread-u...


Objekt TThread

Vzhledem k tomu, že Delphi je především objektový jazyk, je i na thread připraven objekt typu TThread.

Původní jediná funkce se přestěhovala do TThread.Execute, kteroužto je potřeba v každém odvozeném typu override-ovat.

Tento objekt má ovšem řadu dalších vlastností (property) a funkcí, a další je vhodné vystavit v potomkovi...

Je vždy potřeba vytvářet odvozeného potomka, protože samostný TThread je abstraktní třída. V takovém potomkovi je potřeba přinejmenším override-ovat metodu Execute.

Nahlédnutím do Classes.pas v Delphi 5 nebo do manuálu naleznete property a funkce, které objekt TThread vystavuje:


type
  // (Poněkud jsem změnil pořadí a vypustil sekci private...)
  
  TThread=class
  protected
    // virtualizace:
    procedure Execute; virtual; abstract;
    procedure DoTerminate; virtual; // Volání OnTerminate
    // Tyto funkce/property může používat pouze thread sám:
    procedure Synchronize(Method: TThreadMethod);
    property ReturnValue: Integer read F... write F...;
    property Terminated: Boolean read F...;
    //
  public
    //
    constructor Create(CreateSuspended: Boolean);
    destructor Destroy; override;
    //
    procedure Resume;
    procedure Suspend;
    //
    procedure Terminate;
    function WaitFor: LongWord;
    // Property:
    property ThreadID: THandle read F...;
    property Handle: THandle read F...;
    //
    property FreeOnTerminate: Boolean read F... write F...;
    property Suspended: Boolean read F... write Set...;
    property Priority: TThreadPriority read Get... write Set...;
    //
    property OnTerminate: TNotifyEvent read F... write F...;
  end;

Popis funkcí a property: Ne všechny funkce objektu TThread jsou volány v kontextu threadu.
(Například constructor je vždy volán v kontextu jiného (např. hlavního) threadu...
Pokud tedy thread přeci-jen vytváří okna, nelze to dělat v constructoru, ale až na začátku procedury Execute - ta je vždy volána v kontextu threadu, leda by někdo omylem zavolal Thread.Execute v kontextu hlavního threadu, což se nepředpokládá - proto je Execute v sekci protected...)


Destructor může být volán:

Ukázka odvozeného objektu threadu (popis za ukázkou):

type
  PRequest=^TRequest;
  
  TRequestProc=function(Request: Pointer): Longint;
  
  TRequest=record
    Proc:          TRequestProc;
    Params:        array[0..7] of DWORD; // adjust as needed...
  end;
  
  TErrorNotify=procedure(Sender: TObject; E: Exception) of object;
  
  TWorkThread=class(TThread)
  protected
    // Must be in any TThread descendant:
    procedure Execute; override;
    procedure FreeRequest(Req: PRequest); virtual;
    function  PerformRequest(Req: PRequest): integer; virtual;
  private
    // Request queue functions:
    FQueue:        TList;
    FQueueLock:    TRtlCriticalSection;
    FEvent:        THandle;
    FOnError:      TErrorNotify;
    FIdle:         Boolean;
    function  GetNextRequest(var Req: PRequest): Boolean;
  public
    // Creates thread waiting on request:
    constructor Create;
    destructor Destroy; override;
    // Thread stopping:
    procedure StopWorker;
    // Request queueing:
    function  AllocRequest: PRequest;
    function  EnqueueRequest(Request: PRequest): Boolean; 
    procedure CheckQueueCapa(AddCount: integer);
    // Error logging:
    property OnError: TErrorNotify read FOnError write FOnError;
    // For multi-worker management...
    property IsIdle: Boolean read FIdle;                       
  end;

{ TWorkThread }

constructor TWorkThread.Create;
begin
  // Create suspended:
  inherited Create(True);
  // Set FreeOnTerminate:
  Self.FreeOnTerminate:=True; // Thread will destroy itself, when Execute returns...
  // Create request-queue:
  InitializeCriticalSection(FQueueLock);
  FQueue:=TList.Create;
  // Create manual-reset event, initialy not set:
  FEvent:=CreateEvent(nil,True,False,nil);
  // Start the thread:
  Self.Resume;
end;

destructor TWorkThread.Destroy;
var H: THandle;
begin
  // Prevent destructor re-entrance:
  Self.FreeOnTerminate:=False;
  // Set Terminated and release the waiting thread,
  // in case that this is called in context of a main program thread:
  Self.Terminate;
  if (FEvent<>0) then
    SetEvent(FEvent);
  // Wait for the thread:
  inherited Destroy;
  // Cleanup:
  FreeAndNil(FQueue);
  H:=FEvent;
  FEvent:=0;
  CloseHandle(H);
  DeleteCriticalSection(FQueueLock);
end;

procedure TWorkThread.StopWorker;
begin
  // Set Terminated and release the waiting thread,
  // in case that this is called in context of a main program thread:
  Self.Terminate;
  if (FEvent<>0) then
    SetEvent(FEvent);
end;

// Thread procedure:
procedure TWorkThread.Execute;
var Request: PRequest;
begin
  try
    // Check Application.Terminated also for a case,
    // that someone forgot to stop this thread...
    while (not Self.Terminated) and (not Application.Terminated)
    do begin
      // GetNextRequest waits for a request,
      // and returns False, if the thread should abort.
      // Exception from GetNextRequest also aborts the thread:
      if not GetNextRequest(Request) then
        break;
      //
      if (Request=nil) then begin
        // This should not happen, but for a case
        // that someone forgets to reset the event,
        // do not consume 99% CPU:
        Sleep(50);
        continue;
      end;
      //
      try
        // Perform the request:
        PerformRequest(Request);
        //if Assigned(Request.Proc) then ReturnValue:=Request.Proc(Request);
        //
      except ;// on E:Exception do begin
        // Handle request error here:
        if Assigned(FOnError) then
          FOnError(Self,Exception(ExceptObject));
      end; // end;
      // Dispose this request record:
      FreeRequest(Request); // this uses a separate try..except
    end;
    //
    // ... other cleanup in context of the thread...
    // 
  except
    // Main thread catcher.
  end;
end;

function TWorkThread.PerformRequest(Req: PRequest): integer;
begin
  if (Req<>nil) and Assigned(Req.Proc) then
    Result:=Req.Proc(Req)
  else
    Result:=0;
end;

function TWorkThread.AllocRequest: PRequest;
begin
  Result:=AllocMem(SizeOf(TRequest));
end;

procedure TWorkThread.FreeRequest(Req: PRequest);
begin
  if (Req<>nil) then begin
    try
      Finalize(Req^); // ... if the Request contains strings...
      FreeMem(Req);
    except ; end;
  end;
end;

function TWorkThread.EnqueueRequest(Request: PRequest): Boolean;
begin
  // Called in main-thread context...
  if (Request<>nil)
  and (not Self.Terminated)
  then begin
    // Protect TList by critical-section:
    EnterCriticalSection(FQueueLock);
    try
      FQueue.Add(Request);
    finally
      LeaveCriticalSection(FQueueLock);
    end;
    // Release the waiting thread:
    if (FEvent<>0) then
      SetEvent(FEvent);
    //
    Result:=True;
  end else begin
    // Cannot enqueue:
    FreeRequest(Request);
    Result:=False;
  end;
end;

function TWorkThread.GetNextRequest(var Req: PRequest): Boolean;
begin
  // Called in context of the thread to wait for another request...
  Result:=True;
  Req:=nil;
  //
  while True do begin
    //FIdle:=False;
    // Check for a waiting request:
    EnterCriticalSection(FQueueLock);
    try
      if not Self.Terminated
      and (FQueue<>nil)
      then begin
        if (FQueue.Count>0) then begin
          // Get first request: 
          Req:=FQueue.Extract(FQueue.First);
        end else begin
          // Nothing in the queue...
          ResetEvent(FEvent);
        end;
      end else begin
        // Abort worker thread:
        Result:=False;
      end;
    finally
      LeaveCriticalSection(FQueueLock);
    end;
    // if request_found or failure:
    if (Req<>nil) or (not Result) then
      exit;
    // Wait for another request:
    FIdle:=True;
    //
    case WaitForSingleObject(FEvent,INFINITE) of
      WAIT_OBJECT_0: begin
        // Either new request, or termination:
        FIdle:=False;
        if Terminated then begin
          Result:=False;
          exit;
        end;
        //continue;
      end;
      WAIT_FAILED: begin
        // FEvent handle is no more valid??
        // Ignoring this will result in 99% CPU spent in thread-loop...
        FIdle:=False;
        Result:=False;
        exit;
      end;
      else begin
        // This should not happen, but for a case
        // that someone forgets to reset the event,
        // do not consume 99% CPU:
        FIdle:=False;
        Sleep(50);
      end;
    end;
  end;
  // ... unreachable
end;

procedure TWorkThread.CheckQueueCapa(AddCount: integer);
var Capa: integer;
begin
  // Prevent multiple re-allocations during queue-list filling...
  if (AddCount>0)
  and (not Self.Terminated)
  then begin
    // Check, if need to re-allocate the list:
    Capa:=FQueue.Count+AddCount;
    if (Capa>FQueue.Capacity) then begin
      // Protect TList by critical-section:
      EnterCriticalSection(FQueueLock);
      try
        // Grow the list, if needed:
        Capa:=FQueue.Count+AddCount; // recompute again...
        if (Capa>FQueue.Capacity) then
          FQueue.Capacity:=Capa;
      finally
        LeaveCriticalSection(FQueueLock);
      end;
    end;
  end;
end;
// (1286 b code)
V této ukázce:

Synchronizace

Pro komunikaci mezi thready lze použít např.: Pro synchronizaci přístupu ke sdíleným objektům je možné použít: Každý lock v podstatě chrání před tím, aby nebyl jeden thread přerušen v nevhodnou chvíli a jiný thread mezitím nezkusil s nekonzistentním objektem pracovat. Kdyby to mělo nastat, druhý thread začne čekat na critical-section, a teprve až se první thread znovu dostane ke slovu a kritický blok opustí, druhý thread pokračuje.

I když se v 99.9% případů thready i bez locku nepotkají, jen pouhé pokusné ověření, že něco funguje, vůbec neznamená, že problém nemůže nastat - náhoda je nevyzpytatelná...


Thread-Safe

Pokud je předpokládáno, že více threadů najednou bude mít zájem o určitou proměnnou, je potřeba buďto použít nějaký zámek (lock), nebo lépe použít thread-safe funkci pro přístup k této proměnné.
Pod pojmem thread-safe myslím, že ať bude tato funkce přerušena na jakékoli instrukci, výsledek bude dobře definován: např. při alokaci ID nesmí být stejné ID přiděleno dvakrát...

Všechny takové případy by sice šly řešit s použitím CriticalSection, ale ta má jistou (byť malou) režii a někde musí být uložen record TRtlCriticalSection... Navíc při velkém contention (současném zájmu více threadů) by zamykání mohlo zdržovat...

Tento fragment kódu není thread-safe:
function GenId(var NextID: integer): integer;
begin
  Result:=NextID;
  NextID:=Result+1;
end;
Kdyby byl totiž thread přerušen právě mezi těmi dvěma řádkami, a jiný thread se mezitím pokusil o totéž, dostanou oba stejné ID...
A na víceprocesorovém počítači můžou být oba thready vykonávány opravdu současně a oba vykonávat třeba i stejnou instrukci...

Správně by se to tedy napsalo takto:

function GenID(var NextID: integer): integer;
asm
  mov edx,1
  //lea eax,&NextID
  lock xadd dword ptr [eax],edx
  mov eax,edx // Result into EAX
end;

Instrukce xadd se vyskytuje až na 486...
Předpokládáte, že Váš program bude fungovat na 386??


var NextID: integer;
  
  ...
  Result:=InterlockedExchangeAdd(NextID,1);

Tato funkce je ovšem pouza na WinNT!
Funkce InterlockedIncrement nevrací přesnou hodnotu!

Funkce pro bezpečné vyjmutí pointeru (nebo integeru) a nahrazení hodnotou nil se použije, pokud by více než jeden thread chtěli uvolňovat objekt - standardní alokátor není zabezpečen před dvojím uvolněním objektu nebo paměti - v lepším případě to způsobí exception!

function ExtractPtr(var Ptr): Pointer;
asm //                 [EAX]->EAX
  xor edx,edx // store 0
  lock xchg [eax],edx
  //  xchg:   [eax]=edx, edx=orig value
  mov eax,edx // Result into EAX
end;


function ExtractPtr(var Ptr): Pointer;
begin
  Result:=Pointer(
    InterlockedExchange(integer(Ptr),0)
  );
end;


Funkce pro thread-safe alokaci 1 bitu:

function EnterBit(var Bits; Index: integer): Boolean; register;
asm //                EAX   EDX            ->AL
  lock bts [eax],edx
  setnc al // return True, if previous state of bit was 0...
end;

Pro tohle nemám ekvivalent v pascalu...
Další funkce z této série viz DsBits.inc ...


Funkce pro přidání elementu na začátek spojového seznamu:

function NListLinkHead(var NListBase; Item: Pointer): Pointer; register;
asm //                     [EAX]      EDX           ->EAX
  // Item.Next:=NListBase^;
  mov  ecx,[eax]
  mov  [edx],ecx
  // Temp:=Item;
  mov  ecx,edx
  // NListBase^:=Temp; Temp:=orig(NListBase^);
  lock xchg [eax],ecx
  // Item.Next:=Temp;
  cmp  edx,ecx
  je   @skip_link
  mov  [edx],ecx
@skip_link:
  mov  eax,edx
end;

Ekvivalent v pascalu:

type
  PNListItem=^TNListItem;
  TNListItem=record
    Next:          Pointer;
  end;
  
function NListLinkHead(var NListBase; Item: Pointer): Pointer; register;
var Temp: Pointer;
begin
  PNListItem(Item).Next:=Pointer(NListBase);
  Temp:=InterlockedExchange(integer(NListBase),integer(Item));
  if (Temp<>Item) then
    PNListItem(Item).Next:=Temp;
end;

Tato funkce v žádném okamžiku nenechává list odpojený...
Kódem za InterlockedExchange resp. lock xchg si nejsem zcela jistý, ale používám to hodně (tu asm verzi) a ještě jsem si nevšiml žádného problému...


Další ukázky threadů

Vysunutí CD chvíli trvá (většinou i více než vteřinu):

var
  MmSystem: THandle=0;
  MciSendStringA: function (lpstrCommand, lpstrReturnString: PAnsiChar;
    uReturnLength: UINT; hWndCallback: HWND): Longint stdcall=nil;
 
function MciCommand(Cmd: PChar): Boolean;
var ECode: Longint;
begin
  // Vyzvednutí funkce - jen poprvé:
  if not Assigned(MciSendStringA) then begin
    if (MmSystem=0) then begin
      MmSystem:=LoadLibrary('winmm.dll');
      if (MmSystem<=32) then begin
        if (MmSystem=0) then
          inc(MmSystem); // do not retry...
      end else begin
        @MciSendStringA:=GetProcAddress(MmSystem,'mciSendStringA');
      end;
    end;
    if not Assigned(MciSendStringA) then begin
      Result:=False;
      exit;
    end;
  end;
  // Odeslání příkazu MCI:
  ECode:=MciSendStringA(Cmd,nil,0,0);
  Result:=(ECode=0);
end;

function EjectCDThreadProc(Param: Pointer): Longint;
var Buffer: array[0..63] of char;
    Drive: Char;
begin
  try
    Drive:=chr(integer(Param));
    // Příkazy (včetně aliasu foo) opsány z Shell32.dll:
    StrFmt(Buffer,'open %s: type cdaudio alias foo shareable',[Drive]);
    if MciCommand(Buffer) then begin
      MciCommand('set foo door open');
      MciCommand('close foo');
    end;
  except
    //Main thread catcher...
  end;
  Result:=0;
end;

procedure EjectCD(Drive: PChar);
var thh: THandle;
    thid: Cardinal;
begin
  if (Drive<>nil) and (UpCase(Drive^) in ['A'..'Z']) then begin
    thh:=BeginThread(nil,0,@EjectCDThreadProc,Pointer(ord(Drive[0])),0,thid);
    if (thh<>0) then
      CloseHandle(thh);
  end;
end;

procedure TFBrowser.mnEjectCdClick(Sender: TObject);
var Buffer: array[0..3] of char;
Label _ThisCD;
begin
  StrCopy(Buffer,'C:\');
  //
  if (Self.Path<>'')
  and (Self.Path[2]=':')
  then begin
    Buffer[0]:=Self.Path[1];
    if (GetDriveType(Buffer)=DRIVE_CDROM) then
      goto _ThisCD;
  end;
  // Find first CD:
  Buffer[0]:='A';
  repeat
    if (GetDriveType(Buffer)=DRIVE_CDROM) then begin
      // Found a CD:
    _ThisCD:
      EjectCD(Buffer);
      exit;
    end;
    inc(Buffer[0]);
  until (Buffer[0]>'Z');
  // No CD found...
end;

Při umístění funkce v threadu nemusí aplikace čekat tuhá na její dokončení.
Příkazy i metoda na vysunutí CD jsou převzaty z Shell32.dll, kde jsou použity pro příkaz "Vysunout..." v kontextové nabídce disku CD...
Tuhle funkci jsem "vytáhl" ze svého programu a používám ji...


Ukázka zpracování notification typu OnChange, které může přijít v libovolném threadu, ve formuláři, který ovšem musí pracovat ve svém threadu:

  if Self.HandleAllocated then begin
    Wnd:=Self.Handle;
    if (GetCurrentThreadId=GetWindowThreadProcessId(Wnd,nil))
    then begin
      // Main thread:
      RefreshListNow();
      //
    end else begin
      // Other thread:
      KillMessage(Wnd,CM_REFRESHLIST); // volá PeekMessage(...PM_REMOVE)
      PostMessage(Wnd,CM_REFRESHLIST,0,0);
    end;
  end;
 
Tento kus kódu používám a ještě jsem nenarazil na problém. Bez něj ovšem docházelo k problémům, když notification přišlo v contextu work-threadu a formulář začal plnit list-box...

Zdá se, že PeekMessage pro odstranění zprávy z fronty lze volat i z jiného threadu, nebo to aspoň nic špatného nedělá...


Čekání na změnu v adresáři:

const
  CM_RELOADCONFIG = WM_USER+1;

var
  hWatchAbort: THandle;
  WatchThreadId: Cardinal;

function FolderWatchThread(Param: Pointer): Longint;
var hNotify,H: THandle;
    Events: array[0..1] of THandle;
begin
  try
    // Param is Path, allocated by StrNew...
    try
      // Setup abort event:
      if (hWatchAbort=0) then
        hWatchAbort:=CreateEvent(nil,True,False,nil);
      //
      // Setup notification:
      hNotify:=FindFirstChangeNotification(PChar(Param),False,
        FILE_NOTIFY_CHANGE_FILE_NAME or
        FILE_NOTIFY_CHANGE_ATTRIBUTES or
        FILE_NOTIFY_CHANGE_SIZE or
        FILE_NOTIFY_CHANGE_LAST_WRITE);
      // Succeeded?
      if (hNotify<>INVALID_HANDLE_VALUE) then begin
        try
          // Loop for awaiting the next change...
          while not Application.Terminated do begin
            //
            Events[0]:=hNotify;
            Events[1]:=hWatchAbort;
            //
            case WaitForMultipleObjectsEx(1+ord(Events[1]<>0),
              Pointer(@Events[0]),False,INFINITE)
            of
              WAIT_OBJECT_0: begin
                // Something changed in the folder:
                if (Application<>nil)
                and (Application.MainForm<>nil)
                and Application.MainForm.HandleAllocated
                then
                  PostMessage(Application.MainForm.Handle,CM_RELOADCONFIG,0,0)
                else
                  break; // no recipient?
                //
                Sleep(50);
                // Re-setup the notification:
                if not FindNextChangeNotification(hNotify) then
                  break; // notification error??
              end;
              WAIT_OBJECT_0+1: begin
                // hWatchAbort event set...
                break;
              end;
              else begin
                // what else? - no timeout expected...
                Sleep(100);
                break; //? continue;
              end;
            end;
          end;
        finally
          // Close notification handle:
          FindCloseChangeNotification(hNotify);
        end;
      end;
    finally
      // Reset WatchThreadId var:
      if (WatchThreadId=GetCurrentThreadId) then begin
        WatchThreadId:=0;
        // Close event handle:
        H:=hWatchAbort;
        hWatchAbort:=0;
        CloseHandle(H);
      end;
      // Dispose path param:
      StrDispose(Param);
    end;
  except
    // Main thread catcher...
  end;
  Result:=0;
end;

function WatchConfigChange(const Path: string): Boolean;
var Param: PChar;
    thh: THandle;
begin
  // Called for ex. by MainForm.FormCreate...
  Result:=False;
  // Reset abort event:
  if (hWatchAbort<>0) then
    ResetEvent(hWatchAbort);
  //
  if (Path<>'')
  and (WatchThreadId=0)
  then begin
    // Allocate thread param:
    Param:=StrNew(PChar(Path));
    // Create the thread:
    thh:=BeginThread(nil,0,@FolderWatchThread,Param,CREATE_SUSPENDED,WatchThreadId);
    if (thh<>0) then begin
      // Start the thread:
      ResumeThread(thh);
      // Close thread handle:
      CloseHandle(thh);
      //
      Result:=True;
    end else begin
      // Failed to start the thread - dispose param:
      StrDispose(Path);
    end;
  end;
end;

function StopConfigChangeWatch: Boolean;
begin
  // Called for ex. by MainForm.FormClose...
  if (hWatchAbort<>0) then begin
    // Release waiting thread:
    SetEvent(hWatchAbort);
    // Let the thread time to terminate:
    if (WatchThreadId<>0) then
      Sleep(50);
    // Terminated?
    Result:=(WatchThreadId=0);
  end else
    Result:=False;
end;

Poznámka - tento fragment kódu jsem psal jako ukázku pro tento článek a nijak jsem to nezkoušel...

ChangeNotification drží otevřený handle adresáře a tento adresář pak mimo jiné nelze smazat, a rovněž zůstává otevřen v cache, což může urychlit další práci v adresáři...


Ukázka načtení graphického souboru:

type
  PGrLoadParams=^TGrLoadParams;
  TGrLoadParams=record
    FileName:      string;     // in
    PreviewSize:   TPoint;     // in/out
    Picture:       TPicture;   // out
    Preview:       TBitmap;    // out
    Error:         string;     // out
    Wnd:           HWND;       // in - notify wnd
    FormData:      Pointer;    // for caller use...
    Index:         integer;    // for caller use...
    Busy:          Boolean;    // =True if loading
  end;

const
  CM_GRLOADDONE = $7247;       // LParam=PGrThreadParams
                               // Result=NewRequest or 0

function GrLoadThreadProc(Param: Pointer): Longint;
var glp: PGrLoadParams;
    Ptr: Pointer;
    FileName: string;
    Pt: TPoint;
Label _RetryLoad,_DropPreview;
begin
  try
  _RetryLoad:
    glp:=Param;
    glp.Error:='';
    try
      glp.Busy:=True;
      FileName:=glp.FileName;
      // Create TPicture:
      if (glp.Picture=nil) then
        glp.Picture:=TPicture.Create;
      // Load picture file:
      // This may generate exception, if file format unknown:
      glp.Picture.LoadFromFile(glp.FileName);
      // Check, if should generate a preview:
      if (glp.PreviewSize.x>0)
      and (glp.PreviewSize.y>0)
      and (glp.Picture.Graphic<>nil)
      and not glp.Picture.Graphic.Empty
      then begin
        // Adjust preview-size to maintain aspect ratio:
        Pt.x:=glp.Picture.Graphic.Width;
        Pt.y:=glp.Picture.Graphic.Height;
        if not MakePreviewSize(glp.PreviewSize,Pt) then
          goto _DropPreview;
        // Generate preview:
        if (glp.Preview=nil) then
          glp.Preview:=TBitmap.Create;
        glp.Preview.Width:=glp.PreviewSize.x;
        glp.Preview.Height:=glp.PreviewSize.y;
        glp.Preview.Canvas.StretchDraw(
            Rect(0,0,glp.PreviewSize.x,glp.PreviewSize.y),
            glp.Picture.Graphic);
        // Done...
      end else begin
      _DropPreview:
        FreeAndNil(glp.Preview);
      end;
    except on E:Exception do begin
      // Loading failed:
      glp:=Param;
      if IsBadWritePtr(glp,SizeOf(TGrLoadParams))
      or (glp.Error<>'')
      then begin
        // Invalid Params record...
        Result:=2;
        exit;
      end;
      glp.Error:=E.Message;
      FreeAndNil(glp.Picture);
    end; end;
    //
    glp:=Param;
    glp.Busy:=False;
    // Signalize to GUI:
    if (glp.Wnd<>0)
    and IsWindow(glp.Wnd)
    then begin
      Ptr:=Pointer(SendMessage(glp.Wnd,CM_GRLOADDONE,0,Longint(glp)));
      // Previous Param may have been released by form!
      //
      // Check another load request:
      if (Longint(Ptr)>$10000)
      and not IsBadWritePtr(Ptr,SizeOf(TGrLoadParams))
      then begin
        // Returned a pointer... Check load-request:
        glp:=Ptr;
        if (glp<>nil)
        // Check file-name string:
        and (glp.FileName<>'')
        and not IsBadStringPtr(Pointer(glp.FileName),MAX_PATH*2)
        and (integer(StrLen(Pointer(glp.FileName)))=Length(glp.FileName))
        // Check diff file (diff glp record NOT checked - may reuse):
        and not AnsiSameText(glp.FileName,FileName)
        then begin
          // Another request...
          Param:=glp;
          goto _RetryLoad;
        end;
      end;
    end else
    if (glp.Wnd<>0) then begin
      // There was a window, but was destroyed... Free params:
      FreeGrLoadParams(Params);
    end;// else no window - caller will just test Busy later...
  except
    // Main thread catcher...
  end;
  Result:=0;
end;  

function MakePreviewSize(var PreviewSize: TPoint; const ImageSize: TPoint): Boolean;
var rx,ry: Double;
begin
  if (ImageSize.x>0) and (ImageSize.y>0) then begin
    // Default preview size:
    if (PreviewSize.x=0) then
      PreviewSize.x:=120;
    if (PreviewSize.y=0) then
      PreviewSize.y:=80;
    //
    rx:=PreviewSize.x/ImageSize.x;
    ry:=PreviewSize.y/ImageSize.y;
    //
    if (rx>ry) then
      rx:=ry;
    if (rx>1) then
      rx:=1; // Do not generate larger preview than icon
    //
    PreviewSize.x:=Round(ImageSize.x*rx);
    PreviewSize.y:=Round(ImageSize.y*rx);
    //
    Result:=(PreviewSize.x>0) and (PreviewSize.y>0);
  end else
    Result:=False;
end;

function StartGrLoader(Params: PGrLoadParams): Cardinal; //Boolean;
var thh: THandle;
    thid: Cardinal;
begin
  // Check valid params:
  if (Params<>nil)
  and ((Params.Wnd=0) or IsWindow(Params.Wnd))
  then begin
    // Start thread:
    thh:=BeginThread(nil,0,@GrLoadThreadProc,Params,0,thid);
    if (thh<>0) then begin
      // ok.
      CloseHandle(thh);
      //Result:=True;
      Result:=thid;
      exit;
    end;
  end;
  // something failed...
  Result:=0; //False;
end;

procedure FreeGrLoadParams(Params: PGrLoadParams);
begin
  try
    FreeAndNil(Params.Picture);
    FreeAndNil(Params.Preview);
    Finalize(Params^);
    FreeMem(Params);
  except ; end;
end;// (41 b code without except, 83 b with except)
// (1046 b code total)
Tento thread načítá graphic ze souboru do TPicture a generuje preview bitmapu...
Když je s tím hotov, do Params.Wnd (např. Form1.Handle) pošle zprávu CM_GRLOADDONE, ve které formulář prohlížeče aktualizuje svá okna... (tato technika je obdobná TThread.Synchronize)
Je-li potřeba načíst další obrázek, je další Request vrácen v Msg.Result této zprávy (nebo jen vyměněn název v existujícím recordu a tento vrácen) a thread rovnou načte další obrázek...

Opět akademická ukázka...
Je rovněž k dispozici v souboru UGrLoader.pas

(Proč jsem použil zprávu $7247 ? Abych se nepotkal s jinou... - ascii)

Kód, který místo toho zatím používám, viz PictList32.zip, ale potřebuje to některé další nepřiložené unity a balík G32 a je to celé o trochu složitější - ale když už to funguje, nechám to tak...

Použití:

  ...
  private
    FFiles:        TStringList; // []=FileName, Objects[]=TBitmap preview...
    FLoader:       Cardinal; // Just to prevent more loader threads...
    
    procedure CmGrLoadDone(var Msg: TMessage); message CM_GRLOADDONE;
    procedure FolderChanged(Sender: TObject);
    ...
    
procedure TForm1.CmGrLoadDone(var Msg: TMessage);
var glp: PGrLoadParams;
    Index: integer;
begin
  if (Msg.LParam>$10000)
  and not IsBadWritePtr(Pointer(Msg.LParam),SizeOf(TGrLoadParams))
  then begin
    // Previous request done:
    glp:=Pointer(Msg.LParam);
    if (glp.Picture is TPicture) then begin
      // Load suceeded:
      //...
      
      Index:=FFiles.IndexOf(glp.FileName);
      if (Index>=0)
      and (FFiles.Objects[Index]=nil)
      then begin
        FFiles.Objects[Index]:=glp.Preview;
        glp.Preview:=nil;
      end;
      
    end else
    if (glp.Error<>'') then begin
      // Load failed:
      //...
      
      // Without this will re-try the same image again:
      FFiles.Objects[Index]:=TObject(-2); // or FFiles.Delete(Index);
      
    end;
  end else begin
    // Clear invalid number - later just checking =0 :
    Msg.LParam:=Msg.LParam and 0;
  end;
  //
  // Check, if still missing some picture:
  //
  Index:=FFiles.IndexOfObject(nil);
  //
  if (Index>=0) then begin
    // Request new image:
    if (Msg.LParam=0) then begin
      // Do not start second loader:
      if (FLoader<>0) //? and IsValidGrLoader(FLoader)
      then
        exit;
      // Alloc new params:
      glp:=AllocMem(SizeOf(TGrLoadParams));
    end else begin
      // Re-use previous:
      glp:=Pointer(Msg.LParam);
    end;
    //
    glp.FileName:=FFiles[Index];
    //glp.Preview:=nil; // re-use same TBitmap instead if not cleared...
    //glp.Picture:=nil; // re-use same TPicture instead if not cleared...
    //
    // Pass back to thread:
    Msg.Result:=Longint(glp);
    // Check internal call:
    if (Msg.WParam=1)
    and (Msg.LParam=0)
    then begin
      // Start loader now:
      Msg.Result:=Msg.Result and 0;
      FLoader:=StartGrLoader(glp);
    end;
  end else begin
    // Free params record, thread will stop now...
    Msg.Result:=Msg.Result and 0;
    glp:=Pointer(Msg.LParam);
    if (glp<>nil) then begin
      Msg.LParam:=Msg.LParam and 0;
      FreeGrLoadParams(glp);
      //
      FLoader:=0;
    end;
  end;
end;

procedure TForm1.FolderChanged(Sender: TObject);
begin
  // Start loader soon, if some image is missing:
  if (FLoader=0) then
    PostMessage(Self.Handle,CM_GRLOADDONE,1,0);
end;

Procedura zprávy CM_GRLOADDONE je v tomto případě použita: (Zápis Msg.Result:=Msg.Result and 0; namísto Msg.Result:=0; šetří 1 byte kódu a nepotřebuje registr EAX, do kterého tak může kompilátor umístit něco jiného...)


Excelentní ukázka virtualizace threadů a znovu-využití (re-use) objektu TThread viz ve zdrojových kódech INDY:
Nápad se znovu-využitím existujícího objektu vychází z toho, že spuštění threadu není úplně triviální - systém musí přinejmenším alokovat context a segment, upozornit všechny DLL pro alokovaci TLS bloků, atd...
Když je thread po skončení akce pouze suspendován a resumeován při nové potřebě threadu, je to o dost efektivnější, zvláště v případě, kdy se předpokládá časté spouštění threadů...
Místo suspendování by ovšem thread mohl stejně dobře čekat na EVENT, takhle se jenom ušetří ten 1 event...


Ukázka, jak se DLL může rovnou po svém načtení zase nechat od-loadovat:

library AutoUnload;

function UnloadDllProc(Param: Pointer): integer; stdcall;
begin
  // Executed in different thread:
  Sleep(100);
  FreeLibraryAndExitThread(HInstance,0);
  // unreachable...
  Result:=0;
end;

procedure ScheduleUnload;
var thh: THandle;
    thid: Cardinal;
begin
  // The thread should be started after DLL loading
  // has finished, not sooner...
  //
  thh:=CreateThread(nil,0,@UnloadDllProc,nil,0,thid);
  CloseHandle(thh);
end;

procedure DllEntryPoint(Reason: integer);
begin
  try
    case Reason of
      DLL_PROCESS_ATTACH: begin
        //
        ScheduleUnload;
        //
        DoThisOnLibraryLoad();
      end;
    end;
  except
    // prevent exceptions here...
  end;
end;

// Main DLL proc:
begin
  SysInit.DllProc:=@DllEntryPoint;
  DllEntryPoint(DLL_PROCESS_ATTACH);
end.

Tento fragment kódu funguje, i když ještě po vytvoření threadu je spuštěno InputQuery s dotazem uživateli... Spuštěný thread počká na návrat z DllEntryPoint...

Ovšem jinak není dobrý nápad zdržovat v načtení DLL, protože ani jiné thready v programu nejsou v té chvíli spuštěny ani ukončeny!

Jak to vypadá z hlediska procesu - tedy jestli je uvolnění spuštěno těsně před návratem z LoadLibrary nebo až za chvíli - přesně nevím, používám to jinak...
(V TaskView je funkce pro načtení DLL do cílového procesu.)


Zjištění, jestli thread stále ještě pracuje, nebo už skončil:

function IsThreadRunning(ThreadHandle: THandle): Boolean;
var ECode: Cardinal;
begin
  if GetExitCodeThread(ThreadHandle,ECode) then begin
    // Until the thread terminates, this returns STILL_ACTIVE:
    Result:=(ECode=STILL_ACTIVE);
    //
  end else begin
    // Invalid handle...
    Result:=False;
  end;
end;


function IsThreadSuspended(ThreadHandle: Boolean): Boolean;
var Value: Longint;
begin
  // Previous suspend-count is returned from SuspendThread
  // Must NOT be called by the thread itself!
  Value:=SuspendThread(ThreadHandle);
  if (Value<>-1) then begin
    ResumeThread(ThreadHandle);
    //
    Result:=(Value>0);
  end else begin
    // Bad handle or insufficient rights:
    Result:=False;
  end;
end;



Zjištění, co thread právě dělá:

function GetThreadAddress(ThreadHandle: THandle): Pointer;
var Context: Windows.TContext;
begin
  Result:=nil;
  // Bez nastavení bitu CONTEXT_i386 má funkce neblahý následek
  // naplnění více informací a přepsání zásobníku!
  Context.ContextFlags:=CONTEXT_CONTROL;
  // Bez pozastavení threadu nelze zjistit context,
  // pokud thread nečeká např. ve WaitMessage:
  if (integer(SuspendThread(ThreadHandle))<>-1) then begin
    //
    if GetThreadContext(ThreadHandle,Context) then begin
      Result:=Context.EIP;
    end;
    //
    ResumeThread(ThreadHandle);
  end;
end;

Tato funkce vrátí pointer na kód, který právě thread vykonává, nebo nil, když to nelze zjistit...
Je ovšem otázka, k čemu je informace, kde thread čeká...

V mém komerčním programu mám WatchDog thread, který periodicky kouká na proměnnou, kterou program zvedá v Application.OnIdle. Když program ztuhne, něčím takovým vypíšu do logu (ovšem celý context, stack-trace a stack-dump s názvy objektů), co právě dělá...

Zatím stále jenom přemýšlím, jak takový ztuhlý program nějak rozumně odblokovat...
(Kdyby byl program zaseklý v nějaké nekonečné smyčce, možná by pomohlo mu podsunout zavolání SysUtils.Abort, ale většinou někde ztuhne BDE/paradox, a ten není tak snadné přerušit... Při čekání v systémové funkci změna EIP nepomůže...
A aby to nebylo jednoduché - některé operace prostě trvají déle než 15s a není vhodné je přerušovat...)



Funkce pro nouzové přerušení threadu (např. při zaseknutí v nekonečné smyčce) by vypadala asi takto (ale ještě jsem to nezkoušel!):

function AbortThread(ThreadHandle: THandle): Boolean;
var Context: TContext;
    pStack: PDWORD;
begin
  Result:=False;
  //
  if (integer(SuspendThread(ThreadHandle))<>-1) then begin
    try
      // Get context of the thread:
      Context.ContextFlags:=CONTEXT_FULL;
      if GetThreadContext(ThreadHandle,Context) then begin
        // Check NOT executing system code:
        if (Cardinal(Context.Eip)<$70000000) then begin
          // Simulate a call:
          pStack:=Pointer(Context.Esp);
          dec(pStack);
          if not IsBadWritePtr(pStack,4) then begin
            Context.Esp:=DWORD(pStack);
            pStack^:=Context.Eip;
            // Set new EIP address:
            Context.Eip:=DWORD(@SysUtils.Abort);
            // Set context:
            Context.ContextFlags:=CONTEXT_CONTROL;
            Result:=SetThreadContext(ThreadHandle,Context);
          end;
        end;
      end;
    finally
      ResumeThread(ThreadHandle);
    end;
  end;
end;

Tohle by mělo fungovat, pokud jsou na handle dostatečná práva a nečeká-li thread v systému...
Je ovšem otázka, jak poznat, že se to má použít...

(Příznak, v jakém stavu je thread (tedy jestli čeká nebo pracuje) je někde v kernelové části threadu, protože Process Explorer od SysInternals ho zobrazuje, ale (nejen) na to si instaluje driver do jádra... V žádné dokumentované user-mode funkci jsem to nenašel - a hledal jsem pečlivě...
Když thread čeká v jádru, nastavení contextu nijak nepomůže a thread čeká dál...)



Thread může získat svou handle takto:

function GetThreadSelfHandle(Access: Cardinal): THandle;
var hProc: THandle;
begin
  hProc:=GetCurrentProcess;
  if not DuplicateHandle(hProc,GetCurrentThread,hProc,Result,Access,False,0) then
    Result:=0;
end;

Použije se to, je-li např. potřeba handle na hlavní thread aplikace, protože ten nebyl spuštěn funkcí BeginThread, která by vrátila handle...

Access-mask pro thread chybí v unitě Windows.pas (aspoň v Delphi 5):
const
  THREAD_TERMINATE               =$0001;
  THREAD_SUSPEND_RESUME          =$0002;
  THREAD_GET_CONTEXT             =$0008;
  THREAD_SET_CONTEXT             =$0010;
  THREAD_SET_INFORMATION         =$0020;
  THREAD_QUERY_INFORMATION       =$0040;
  THREAD_SET_THREAD_TOKEN        =$0080;
  THREAD_IMPERSONATE             =$0100;
  THREAD_DIRECT_IMPERSONATION    =$0200;
  
  THREAD_ALL_ACCESS              = STANDARD_RIGHTS_REQUIRED or
                                   SYNCHRONIZE or
                                   $3FF; // == $1F03FF;

Význam bitu $0004 jsem ve winnt.h nenašel, ale je definován v GENERIC_WRITE...
Vyšší hodnoty ve spodním wordu nejsou (aspoň na Win2k) definovány...

Dále na Win2k a možná i WinXP pro thread: Tyto hodnoty lze zjistit např. funkcí NtQueryObject s levelem ObjectTypeInformation, kde je vrácen mimo jiné i record GENERIC_MAPPING...


Další ukázka - unita UPlayerThread.pas - ve které je zobecněný přehrávač hudby, který pracuje v jiném threadu než GUI programu, aby program nebyl závislý na zvůli 3rd-party přehrávače (např. Elamp.esp si občas zamkne nějakou critical-section...)

Celý program jsem ještě nezprovoznil, ale v overridovaném threadu už to hudbu přehrává pomocí bass.dll, chybí mi spíš dodělat formulář play-listu...

Podotýkám, že to používá další unity, které nejsou přiloženy... Obzvláště definice různých interface si ještě zaslouží před zveřejněním doplnit. Také tomu zatím chybí odchycení exception, protože moje upravená nadstavba žádné úmyslně negeneruje...


Potomek TThreadu čeká na event nebo message a zpracovává TRequest požadavky, obdobně jako v ukázce TWorkThread v tomto článku výše.
Je zastaven při uvolnění posledního interface procedurou IntfReleased...


Seznam RtlCriticalSection v processu:


type
  // Return True as found/stop, False to continue...
  TCritSecEnumProc=function(Arg: Pointer; CritSec: PRtlCriticalSection): Boolean;

function EnumCriticalSections(const Enum: TCritSecEnumProc; Arg: Pointer): Pointer;


function IsValidCritSec(CritSec: PRtlCriticalSection): Boolean;
function IsLockedCritSec(CritSec: PRtlCriticalSection): Boolean;


function UnlockCritSec(CritSec: PRtlCriticalSection): Boolean;
function UnlockAllCritSecs: Boolean;


implementation

function SeekListEntryBack(ListEntry: PListEntry): PListEntry;
begin
  if (ListEntry<>nil) then
    while (ListEntry.BLink<>nil) do
      ListEntry:=ListEntry.BLink;
  Result:=ListEntry;
end;

function EnumCriticalSections(const Enum: TCritSecEnumProc; Arg: Pointer): Pointer;
var TempCs: TRtlCriticalSection;
    csd,Acsd: PRTLCriticalSectionDebug;
begin
  if not Assigned(Enum) then begin
    Result:=nil;
    exit;
  end;
  // Get a chain item:
  InitializeCriticalSection(TempCs);
  try
    csd:=TempCs.DebugInfo;
    if (csd<>nil) then begin
      csd:=Pointer(Longint(SeekListEntryBack(@csd.ProcessLocksList))-8);
      if (csd=TempCs.Debug) then begin
        // Skip this one:
        if (csd.ProcessLocksList.FLink=nil) then begin
          Result:=csd.ProcessLocksList.FLink; //nil;
          exit;
        end;
        csd:=Pointer(Longint(csd.ProcessLocksList.FLink)-8);
      end;
    end;
    Acsd:=csd; // store to stack through finally...
  finally
    // Release a chain item:
    DeleteCriticalSection(TempCs);
  end;
  //
  try
    csd:=Acsd;
    while (csd<>nil) do begin
      // Take Next before calling Enum-proc:
      Acsd:=Pointer(Longint(csd.ProcessLocksList.FLink)-8);
      //
      if Enum(Arg,csd.CriticalSection) then begin
        Result:=csd.CriticalSection;
        exit;
      end;
      //
      //csd:=Pointer(Longint(csd.ProcessLocksList.FLink)-8);
      csd:=Acsd;
    end;
  except
    //? list unexpectedly modified during walking?
  end;
  //
  Result:=nil;
end;

function IsValidCritSec(CritSec: PRtlCriticalSection): Boolean;
begin
  if (CritSec<>nil)
  and not IsBadWritePtr(CritSec,SizeOf(TRtlCriticalSection))
  and (CritSec.DebugInfo<>nil)
  and not IsBadWritePtr(CritSec.DebugInfo,SizeOf(TRtlCriticalSectionDebug))
  and (CritSec.DebugInfo.CriticalSection=CritSec)
  then
    Result:=True
  else
    Result:=False;
end;

function IsLockedCritSec(CritSec: PRtlCriticalSection): Boolean;
begin
  if //(CritSec<>nil) and
     IsValidCritSec(CritSec)
  then
    Result:=//(CritSec.LockCount<>-1) and/or
        (CritSec.RecursionCount<>0)
  else
    Result:=False;
end;

function UnlockCritSec(CritSec: PRtlCriticalSection): Boolean;
var csd: PRtlCriticalSectionDebug;
begin
  if IsLockedCritSec(CritSec) then begin
    csd:=CritSec.DebugInfo;
    if (csd<>nil) then begin
      csd.EntryCount:=csd.EntryCount and 0;
      csd.ContentionCount:=csd.ContentionCount and 0;
    end;
    CritSec.RecursionCount:=CritSec.RecursionCount and 0;
    CritSec.OwningThread:=CritSec.OwningThread and 0;
    CritSec.LockCount:=CritSec.LockCount or -1; // -1 if not locked...
    //
    if (CritSec.LockSemaphore<>0) then
      Result:=SetEvent(CritSec.LockSemaphore) // NT uses auto-reset Event...
    else
      Result:=False;
  end else
    Result:=False;
end;

function CritSecUnlockProc(Arg: Pointer; CritSec: PRtlCriticalSection): Boolean;
var i: integer;
begin
  if IsLockedCritSec(CritSec) then begin
    // Check for a temporary condition:
    i:=10;
    repeat
      Sleep(10);
      if not IsLockedCritSec(CritSec) then
        break;
      dec(i);
    until (i=0);
    //
    if (i=0) then begin
      // Long-locked crit-sec found:
      UnlockCritSec(CritSec);
      Boolean(Arg^):=True;
    end;
  end;
  //
  Result:=False; // enum all...
end;

function UnlockAllCritSecs: Boolean;
var Tries: integer;
    bnFound: Boolean;
begin
  Result:=False;
  Tries:=100;
  repeat
    bnFound:=False;
    EnumCriticalSections(@CritSecUnlockProc,@bnFound);
    Result:=Result or bnFound;
    dec(Tries);
  until (Tries=0) or (not bnFound);
end;

Tyto funkce využívají faktu, že všechny RTLCriticalSection jsou přes DebugInfo spojeny do spojového seznamu funkcí InitializeCriticalSection...
Pro získání jednoho prvku tohoto seznamu je vytvořena dočasná critical-section...

(Takhle programaticky jsem to ještě nezkoušel, ale občas takhle ručně odblokuji zamrzlý process...)

Nejsem si také jist, jestli přítomnost DebugInfo je něčím ovlivněna...
Na mém počítači jsou ale v každém procesu...

Je-li nějaká CriticalSection dlouhodobě zamčená, lze to považovat za chybu...
Místo funkce na odblokování je samozřejmě lepší používat try..finally, pokud to jde,
ovšem při používání DLL, napsaných v C někým jiným, se může hodit i tato funkce...


(c) Semi, 09/2004