1{ 2 This file is part of the Free Component Library (FCL) 3 Copyright (c) 1999-2000 by Peter Vreman 4 5 BeOS TThread implementation 6 7 See the file COPYING.FPC, included in this distribution, 8 for details about the copyright. 9 10 This program is distributed in the hope that it will be useful, 11 but WITHOUT ANY WARRANTY; without even the implied warranty of 12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 14 **********************************************************************} 15 16 17{$IFDEF VER1_0} // leaving the old implementation in for now... 18type 19 PThreadRec=^TThreadRec; 20 TThreadRec=record 21 thread : TThread; 22 next : PThreadRec; 23 end; 24 25var 26 ThreadRoot : PThreadRec; 27 ThreadsInited : boolean; 28// MainThreadID: longint; 29 30Const 31 ThreadCount: longint = 0; 32 33function ThreadSelf:TThread; 34var 35 hp : PThreadRec; 36 sp : Pointer; 37begin 38 sp:=SPtr; 39 hp:=ThreadRoot; 40 while assigned(hp) do 41 begin 42 if (sp<=hp^.Thread.FStackPointer) and 43 (sp>(hp^.Thread.FStackPointer-hp^.Thread.FStackSize)) then 44 begin 45 Result:=hp^.Thread; 46 exit; 47 end; 48 hp:=hp^.next; 49 end; 50 Result:=nil; 51end; 52 53 54//function SIGCHLDHandler(Sig: longint): longint; cdecl;//this is std linux C declaration as function 55procedure SIGCHLDHandler(Sig: longint); cdecl; 56 57begin 58 fpwaitpid(-1, nil, WNOHANG); 59end; 60 61procedure InitThreads; 62var 63 Act, OldAct: Baseunix.PSigActionRec; 64begin 65 ThreadRoot:=nil; 66 ThreadsInited:=true; 67 68 69// This will install SIGCHLD signal handler 70// signal() installs "one-shot" handler, 71// so it is better to install and set up handler with sigaction() 72 73 GetMem(Act, SizeOf(SigActionRec)); 74 GetMem(OldAct, SizeOf(SigActionRec)); 75 76 Act^.sa_handler := TSigAction(@SIGCHLDHandler); 77 Act^.sa_flags := SA_NOCLDSTOP {or SA_NOMASK or SA_RESTART}; 78 Fillchar(Act^.sa_mask,sizeof(Act^.sa_mask),0); //Do not block all signals ??. Don't need if SA_NOMASK in flags 79 FpSigAction(SIGCHLD, Act, OldAct); 80 81 FreeMem(Act, SizeOf(SigActionRec)); 82 FreeMem(OldAct, SizeOf(SigActionRec)); 83end; 84 85 86procedure DoneThreads; 87var 88 hp : PThreadRec; 89begin 90 while assigned(ThreadRoot) do 91 begin 92 ThreadRoot^.Thread.Destroy; 93 hp:=ThreadRoot; 94 ThreadRoot:=ThreadRoot^.Next; 95 dispose(hp); 96 end; 97 ThreadsInited:=false; 98end; 99 100 101procedure AddThread(t:TThread); 102var 103 hp : PThreadRec; 104begin 105 { Need to initialize threads ? } 106 if not ThreadsInited then 107 InitThreads; 108 109 { Put thread in the linked list } 110 new(hp); 111 hp^.Thread:=t; 112 hp^.next:=ThreadRoot; 113 ThreadRoot:=hp; 114 115 inc(ThreadCount, 1); 116end; 117 118 119procedure RemoveThread(t:TThread); 120var 121 lasthp,hp : PThreadRec; 122begin 123 hp:=ThreadRoot; 124 lasthp:=nil; 125 while assigned(hp) do 126 begin 127 if hp^.Thread=t then 128 begin 129 if assigned(lasthp) then 130 lasthp^.next:=hp^.next 131 else 132 ThreadRoot:=hp^.next; 133 dispose(hp); 134 exit; 135 end; 136 lasthp:=hp; 137 hp:=hp^.next; 138 end; 139 140 Dec(ThreadCount, 1); 141 if ThreadCount = 0 then DoneThreads; 142end; 143 144 145{ TThread } 146function ThreadProc(args:pointer): Integer;//cdecl; 147var 148 FreeThread: Boolean; 149 Thread : TThread absolute args; 150begin 151 while Thread.FHandle = 0 do fpsleep(1); 152 if Thread.FSuspended then Thread.suspend(); 153 try 154 CurrentThreadVar := Thread; 155 Thread.Execute; 156 except 157 Thread.FFatalException := TObject(AcquireExceptionObject); 158 end; 159 FreeThread := Thread.FFreeOnTerminate; 160 Result := Thread.FReturnValue; 161 Thread.FFinished := True; 162 Thread.DoTerminate; 163 if FreeThread then 164 Thread.Free; 165 fpexit(Result); 166end; 167 168 169procedure TThread.SysCreate(CreateSuspended: Boolean; 170 const StackSize: SizeUInt); 171var 172 Flags: Integer; 173begin 174 AddThread(self); 175 FSuspended := CreateSuspended; 176 Flags := CLONE_VM + CLONE_FS + CLONE_FILES + CLONE_SIGHAND + SIGCHLD; 177 { Setup 16k of stack } 178 FStackSize:=16384; 179 Getmem(FStackPointer,StackSize); 180 inc(FStackPointer,StackSize); 181 FCallExitProcess:=false; 182 { Clone } 183 FHandle:= Clone(@ThreadProc,FStackPointer,Flags,self); 184// if FSuspended then Suspend; 185 FThreadID := FHandle; 186 IsMultiThread := TRUE; 187 FFatalException := nil; 188end; 189 190 191procedure TThread.SysDestroy; 192begin 193 if not FFinished and not Suspended then 194 begin 195 Terminate; 196 WaitFor; 197 end; 198 if FHandle <> -1 then 199 fpkill(FHandle, SIGKILL); 200 dec(FStackPointer,FStackSize); 201 Freemem(FStackPointer); 202 FFatalException.Free; 203 FFatalException := nil; 204 RemoveThread(self); 205end; 206 207 208procedure TThread.CallOnTerminate; 209begin 210 FOnTerminate(Self); 211end; 212 213procedure TThread.DoTerminate; 214begin 215 if Assigned(FOnTerminate) then 216 Synchronize(@CallOnTerminate); 217end; 218 219 220const 221{ I Don't know idle or timecritical, value is also 20, so the largest other 222 possibility is 19 (PFV) } 223 Priorities: array [TThreadPriority] of Integer = 224 (-20,-19,-10,9,10,19,20); 225 226function TThread.GetPriority: TThreadPriority; 227var 228 P: Integer; 229 I: TThreadPriority; 230begin 231 P := fpGetPriority(Prio_Process,FHandle); 232 Result := tpNormal; 233 for I := Low(TThreadPriority) to High(TThreadPriority) do 234 if Priorities[I] = P then 235 Result := I; 236end; 237 238 239procedure TThread.SetPriority(Value: TThreadPriority); 240begin 241 fpSetPriority(Prio_Process,FHandle,Priorities[Value]); 242end; 243 244 245procedure TThread.Synchronize(Method: TThreadMethod); 246begin 247end; 248 249 250procedure TThread.SetSuspended(Value: Boolean); 251begin 252 if Value <> FSuspended then 253 if Value then 254 Suspend 255 else 256 Resume; 257end; 258 259 260procedure TThread.Suspend; 261begin 262 FSuspended := true; 263 fpKill(FHandle, SIGSTOP); 264end; 265 266 267procedure TThread.Resume; 268begin 269 fpKill(FHandle, SIGCONT); 270 FSuspended := False; 271end; 272 273 274procedure TThread.Terminate; 275begin 276 FTerminated := True; 277 TerminatedSet; 278end; 279 280function TThread.WaitFor: Integer; 281var 282 status : longint; 283begin 284 if FThreadID = MainThreadID then 285 fpwaitpid(0,@status,0) 286 else 287 fpwaitpid(FHandle,@status,0); 288 Result:=status; 289end; 290{$ELSE} 291 292{ 293 What follows, is a short description on my implementation of TThread. 294 Most information can also be found by reading the source and accompanying 295 comments. 296 297 A thread is created using BeginThread, which in turn calls 298 pthread_create. So the threads here are always posix threads. 299 Posix doesn't define anything for suspending threads as this is 300 inherintly unsafe. Just don't suspend threads at points they cannot 301 control. Therefore, I didn't implement .Suspend() if its called from 302 outside the threads execution flow (except on Linux _without_ NPTL). 303 304 The implementation for .suspend uses a semaphore, which is initialized 305 at thread creation. If the thread tries to suspend itself, we simply 306 let it wait on the semaphore until it is unblocked by someone else 307 who calls .Resume. 308 309 If a thread is supposed to be suspended (from outside its own path of 310 execution) on a system where the symbol LINUX is defined, two things 311 are possible. 312 1) the system has the LinuxThreads pthread implementation 313 2) the system has NPTL as the pthread implementation. 314 315 In the first case, each thread is a process on its own, which as far as 316 know actually violates posix with respect to signal handling. 317 But we can detect this case, because getpid(2) will 318 return a different PID for each thread. In that case, sending SIGSTOP 319 to the PID associated with a thread will actually stop that thread 320 only. 321 In the second case, this is not possible. But getpid(2) returns the same 322 PID across all threads, which is detected, and TThread.Suspend() does 323 nothing in that case. This should probably be changed, but I know of 324 no way to suspend a thread when using NPTL. 325 326 If the symbol LINUX is not defined, then the unimplemented 327 function SuspendThread is called. 328 329 Johannes Berg <johannes@sipsolutions.de>, Sunday, November 16 2003 330} 331 332// ========== semaphore stuff ========== 333{ 334 I don't like this. It eats up 2 filedescriptors for each thread, 335 and those are a limited resource. If you have a server programm 336 handling client connections (one per thread) it will not be able 337 to handle many if we use 2 fds already for internal structures. 338 However, right now I don't see a better option unless some sem_* 339 functions are added to systhrds. 340 I encapsulated all used functions here to make it easier to 341 change them completely. 342} 343 344{BeOS implementation} 345 346function SemaphoreInit: Pointer; 347begin 348 SemaphoreInit := GetMem(SizeOf(TFilDes)); 349 fppipe(PFilDes(SemaphoreInit)^); 350end; 351 352procedure SemaphoreWait(const FSem: Pointer); 353var 354 b: byte; 355begin 356 fpread(PFilDes(FSem)^[0], b, 1); 357end; 358 359procedure SemaphorePost(const FSem: Pointer); 360var 361 b : byte; 362begin 363 b := 0; 364 fpwrite(PFilDes(FSem)^[1], b, 1); 365end; 366 367procedure SemaphoreDestroy(const FSem: Pointer); 368begin 369 fpclose(PFilDes(FSem)^[0]); 370 fpclose(PFilDes(FSem)^[1]); 371 FreeMemory(FSem); 372end; 373 374// =========== semaphore end =========== 375 376var 377 ThreadsInited: boolean = false; 378{$IFDEF LINUX} 379 GMainPID: LongInt = 0; 380{$ENDIF} 381const 382 // stupid, considering its not even implemented... 383 Priorities: array [TThreadPriority] of Integer = 384 (-20,-19,-10,0,9,18,19); 385 386procedure InitThreads; 387begin 388 if not ThreadsInited then begin 389 ThreadsInited := true; 390 {$IFDEF LINUX} 391 GMainPid := fpgetpid(); 392 {$ENDIF} 393 end; 394end; 395 396procedure DoneThreads; 397begin 398 ThreadsInited := false; 399end; 400 401{ ok, so this is a hack, but it works nicely. Just never use 402 a multiline argument with WRITE_DEBUG! } 403{$MACRO ON} 404{$IFDEF DEBUG_MT} 405{$define WRITE_DEBUG := writeln} // actually write something 406{$ELSE} 407{$define WRITE_DEBUG := //} // just comment out those lines 408{$ENDIF} 409 410function ThreadFunc(parameter: Pointer): LongInt; // cdecl; 411var 412 LThread: TThread; 413 c: char; 414begin 415 WRITE_DEBUG('ThreadFunc is here...'); 416 LThread := TThread(parameter); 417 {$IFDEF LINUX} 418 // save the PID of the "thread" 419 // this is different from the PID of the main thread if 420 // the LinuxThreads implementation is used 421 LThread.FPid := fpgetpid(); 422 {$ENDIF} 423 WRITE_DEBUG('thread initing, parameter = ', LongInt(LThread)); 424 try 425 if LThread.FInitialSuspended then begin 426 SemaphoreWait(LThread.FSem); 427 if not LThread.FInitialSuspended then begin 428 CurrentThreadVar := LThread; 429 WRITE_DEBUG('going into LThread.Execute'); 430 LThread.Execute; 431 end; 432 end else begin 433 CurrentThreadVar := LThread; 434 WRITE_DEBUG('going into LThread.Execute'); 435 LThread.Execute; 436 end; 437 except 438 on e: exception do begin 439 WRITE_DEBUG('got exception: ',e.message); 440 LThread.FFatalException := TObject(AcquireExceptionObject); 441 // not sure if we should really do this... 442 // but .Destroy was called, so why not try FreeOnTerminate? 443 if e is EThreadDestroyCalled then LThread.FFreeOnTerminate := true; 444 end; 445 end; 446 WRITE_DEBUG('thread done running'); 447 Result := LThread.FReturnValue; 448 WRITE_DEBUG('Result is ',Result); 449 LThread.FFinished := True; 450 LThread.DoTerminate; 451 if LThread.FreeOnTerminate then begin 452 WRITE_DEBUG('Thread should be freed'); 453 LThread.Free; 454 WRITE_DEBUG('Thread freed'); 455 end; 456 WRITE_DEBUG('thread func exiting'); 457end; 458 459{ TThread } 460procedure TThread.SysCreate(CreateSuspended: Boolean; const StackSize: SizeUInt); 461var 462 data : pointer; 463begin 464 // lets just hope that the user doesn't create a thread 465 // via BeginThread and creates the first TThread Object in there! 466 InitThreads; 467 FSem := SemaphoreInit; 468 FSuspended := CreateSuspended; 469 FSuspendedExternal := false; 470 FInitialSuspended := CreateSuspended; 471 FFatalException := nil; 472 WRITE_DEBUG('creating thread, self = ',longint(self)); 473 FHandle:= BeginThread(@ThreadFunc, Pointer(Self), FThreadID); 474 WRITE_DEBUG('TThread.Create done'); 475end; 476 477 478procedure TThread.SysDestroy; 479begin 480 if FThreadID = GetCurrentThreadID then begin 481 raise EThreadDestroyCalled.Create('A thread cannot destroy itself except by setting FreeOnTerminate and leaving!'); 482 end; 483 // if someone calls .Free on a thread with 484 // FreeOnTerminate, then don't crash! 485 FFreeOnTerminate := false; 486 if not FFinished and not FSuspended then begin 487 Terminate; 488 WaitFor; 489 end; 490 if (FInitialSuspended) then begin 491 // thread was created suspended but never woken up. 492 SemaphorePost(FSem); 493 WaitFor; 494 end; 495 FFatalException.Free; 496 FFatalException := nil; 497 SemaphoreDestroy(FSem); 498end; 499 500procedure TThread.SetSuspended(Value: Boolean); 501begin 502 if Value <> FSuspended then 503 if Value then 504 Suspend 505 else 506 Resume; 507end; 508 509procedure TThread.Suspend; 510begin 511 if not FSuspended then begin 512 if FThreadID = GetCurrentThreadID then begin 513 FSuspended := true; 514 SemaphoreWait(FSem); 515 end else begin 516 FSuspendedExternal := true; 517{$IFDEF LINUX} 518 // naughty hack if the user doesn't have Linux with NPTL... 519 // in that case, the PID of threads will not be identical 520 // to the other threads, which means that our thread is a normal 521 // process that we can suspend via SIGSTOP... 522 // this violates POSIX, but is the way it works on the 523 // LinuxThreads pthread implementation. Not with NPTL, but in that case 524 // getpid(2) also behaves properly and returns the same PID for 525 // all threads. Thats actually (FINALLY!) native thread support :-) 526 if FPid <> GMainPID then begin 527 FSuspended := true; 528 fpkill(FPid, SIGSTOP); 529 end; 530{$ELSE} 531 SuspendThread(FHandle); 532{$ENDIF} 533 end; 534 end; 535end; 536 537 538procedure TThread.Resume; 539begin 540 if (not FSuspendedExternal) then begin 541 if FSuspended then begin 542 SemaphorePost(FSem); 543 FInitialSuspended := false; 544 FSuspended := False; 545 end; 546 end else begin 547{$IFDEF LINUX} 548 // see .Suspend 549 if FPid <> GMainPID then begin 550 fpkill(FPid, SIGCONT); 551 FSuspended := False; 552 end; 553{$ELSE} 554 ResumeThread(FHandle); 555{$ENDIF} 556 FSuspendedExternal := false; 557 end; 558end; 559 560 561procedure TThread.Terminate; 562begin 563 FTerminated := True; 564 TerminatedSet; 565end; 566 567function TThread.WaitFor: Integer; 568begin 569 WRITE_DEBUG('waiting for thread ',FHandle); 570 WaitFor := WaitForThreadTerminate(FHandle, 0); 571 WRITE_DEBUG('thread terminated'); 572end; 573 574procedure TThread.CallOnTerminate; 575begin 576 // no need to check if FOnTerminate <> nil, because 577 // thats already done in DoTerminate 578 FOnTerminate(self); 579end; 580 581procedure TThread.DoTerminate; 582begin 583 if Assigned(FOnTerminate) then 584 Synchronize(@CallOnTerminate); 585end; 586 587function TThread.GetPriority: TThreadPriority; 588var 589 P: Integer; 590 I: TThreadPriority; 591begin 592 P := ThreadGetPriority(FHandle); 593 Result := tpNormal; 594 for I := Low(TThreadPriority) to High(TThreadPriority) do 595 if Priorities[I] = P then 596 Result := I; 597end; 598 599(* 600procedure TThread.Synchronize(Method: TThreadMethod); 601begin 602{$TODO someone with more clue of the GUI stuff will have to do this} 603end; 604*) 605procedure TThread.SetPriority(Value: TThreadPriority); 606begin 607 ThreadSetPriority(FHandle, Priorities[Value]); 608end; 609{$ENDIF} 610 611