cthreads.pp 27 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 2002 by Peter Vreman,
  4. member of the Free Pascal development team.
  5. pthreads threading support implementation
  6. See the file COPYING.FPC, included in this distribution,
  7. for details about the copyright.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  11. **********************************************************************}
  12. {$mode objfpc}
  13. {$ifdef linux}
  14. { we can combine both compile-time linking and dynamic loading, in order to:
  15. a) solve a problem on some systems with dynamically loading libpthread if
  16. it's not linked at compile time
  17. b) still enabling dynamically checking whether or not certain functions
  18. are available (could also be implemented via weak linking)
  19. }
  20. {$linklib pthread}
  21. {$define dynpthreads} // Useless on BSD, since they are in libc
  22. {$endif}
  23. { sem_init is best, since it does not consume any file descriptors. }
  24. { sem_open is second best, since it consumes only one file descriptor }
  25. { per semaphore. }
  26. { If neither is available, pipe is used as fallback, which consumes 2 }
  27. { file descriptors per semaphore. }
  28. { Darwin doesn't support nameless semaphores in at least }
  29. { Mac OS X 10.4.8/Darwin 8.8 }
  30. {$if not defined(darwin) and not defined(iphonesim)}
  31. {$define has_sem_init}
  32. {$define has_sem_getvalue}
  33. {$else }
  34. {$if defined(darwin) or defined(iphonesim)}
  35. {$define has_sem_open}
  36. {$endif}
  37. {$endif}
  38. {$if defined(linux) or defined(aix) or defined(android)}
  39. {$define has_sem_timedwait}
  40. {$endif}
  41. unit cthreads;
  42. interface
  43. {$S-}
  44. {$ifndef dynpthreads} // If you have problems compiling this on FreeBSD 5.x
  45. {$linklib c} // try adding -Xf
  46. {$if not defined(Darwin) and not defined(iphonesim) and not defined(Android)}
  47. {$ifndef haiku}
  48. {$linklib pthread}
  49. {$endif haiku}
  50. {$endif darwin}
  51. {$endif}
  52. {$define basicevents_with_pthread_cond}
  53. Procedure SetCThreadManager;
  54. implementation
  55. Uses
  56. BaseUnix,
  57. unix,
  58. unixtype,
  59. initc
  60. {$ifdef dynpthreads}
  61. ,dl
  62. {$endif}
  63. ;
  64. {*****************************************************************************
  65. System unit import
  66. *****************************************************************************}
  67. procedure fpc_threaderror; [external name 'FPC_THREADERROR'];
  68. {*****************************************************************************
  69. Generic overloaded
  70. *****************************************************************************}
  71. { Include OS specific parts. }
  72. {$i pthread.inc}
  73. Type PINTRTLEvent = ^TINTRTLEvent;
  74. TINTRTLEvent = record
  75. condvar: pthread_cond_t;
  76. mutex: pthread_mutex_t;
  77. isset: boolean;
  78. end;
  79. TTryWaitResult = (tw_error, tw_semwasunlocked, tw_semwaslocked);
  80. {*****************************************************************************
  81. Threadvar support
  82. *****************************************************************************}
  83. const
  84. threadvarblocksize : dword = 0;
  85. var
  86. TLSKey,
  87. CleanupKey : pthread_key_t;
  88. procedure CInitThreadvar(var offset : dword;size : dword);
  89. begin
  90. {$ifdef cpusparc}
  91. threadvarblocksize:=align(threadvarblocksize,16);
  92. {$endif cpusparc}
  93. {$ifdef cpusparc64}
  94. threadvarblocksize:=align(threadvarblocksize,16);
  95. {$endif cpusparc64}
  96. {$ifdef cpupowerpc}
  97. threadvarblocksize:=align(threadvarblocksize,8);
  98. {$endif cpupowerc}
  99. {$ifdef cpui386}
  100. threadvarblocksize:=align(threadvarblocksize,8);
  101. {$endif cpui386}
  102. {$ifdef cpuarm}
  103. threadvarblocksize:=align(threadvarblocksize,4);
  104. {$endif cpuarm}
  105. {$ifdef cpum68k}
  106. threadvarblocksize:=align(threadvarblocksize,2);
  107. {$endif cpum68k}
  108. {$ifdef cpux86_64}
  109. threadvarblocksize:=align(threadvarblocksize,16);
  110. {$endif cpux86_64}
  111. {$ifdef cpupowerpc64}
  112. threadvarblocksize:=align(threadvarblocksize,16);
  113. {$endif cpupowerpc64}
  114. {$ifdef cpuaarch64}
  115. threadvarblocksize:=align(threadvarblocksize,16);
  116. {$endif cpuaarch64}
  117. offset:=threadvarblocksize;
  118. inc(threadvarblocksize,size);
  119. end;
  120. procedure CAllocateThreadVars;
  121. var
  122. dataindex : pointer;
  123. begin
  124. { we've to allocate the memory from system }
  125. { because the FPC heap management uses }
  126. { exceptions which use threadvars but }
  127. { these aren't allocated yet ... }
  128. { allocate room on the heap for the thread vars }
  129. DataIndex:=Pointer(Fpmmap(nil,threadvarblocksize,3,MAP_PRIVATE+MAP_ANONYMOUS,-1,0));
  130. FillChar(DataIndex^,threadvarblocksize,0);
  131. pthread_setspecific(tlskey,dataindex);
  132. end;
  133. procedure CthreadCleanup(p: pointer); cdecl;
  134. {$ifdef DEBUG_MT}
  135. var
  136. s: string[100]; // not an ansistring
  137. {$endif DEBUG_MT}
  138. begin
  139. {$ifdef DEBUG_MT}
  140. s := 'finishing externally started thread'#10;
  141. fpwrite(0,s[1],length(s));
  142. {$endif DEBUG_MT}
  143. { Restore tlskey value as it may already have been set to null,
  144. in which case
  145. a) DoneThread can't release the memory
  146. b) accesses to threadvars from DoneThread or anything it
  147. calls would allocate new threadvar memory
  148. }
  149. pthread_setspecific(tlskey,p);
  150. { clean up }
  151. DoneThread;
  152. { the pthread routine that calls us is supposed to do this, but doesn't
  153. at least on Mac OS X 10.6 }
  154. pthread_setspecific(CleanupKey,nil);
  155. pthread_setspecific(tlskey,nil);
  156. end;
  157. procedure HookThread;
  158. begin
  159. { Allocate local thread vars, this must be the first thing,
  160. because the exception management and io depends on threadvars }
  161. CAllocateThreadVars;
  162. { we cannot know the stack size of the current thread, so pretend it
  163. is really large to prevent spurious stack overflow errors }
  164. InitThread(1000000000);
  165. { instruct the pthreads system to clean up this thread when it exits.
  166. Use current tlskey as value so that if tlskey is cleared before
  167. CleanupKey is called, we still know its value (the order in which
  168. pthread tls data is zeroed by pthreads is undefined, and under some
  169. systems the tlskey is cleared first) }
  170. pthread_setspecific(CleanupKey,pthread_getspecific(tlskey));
  171. end;
  172. function CRelocateThreadvar(offset : dword) : pointer;
  173. var
  174. P : Pointer;
  175. begin
  176. P:=pthread_getspecific(tlskey);
  177. { a thread which we did not create? }
  178. if (P=Nil) then
  179. begin
  180. HookThread;
  181. // If this also goes wrong: bye bye threadvars...
  182. P:=pthread_getspecific(tlskey);
  183. end;
  184. CRelocateThreadvar:=P+Offset;
  185. end;
  186. procedure CReleaseThreadVars;
  187. begin
  188. Fpmunmap(pointer(pthread_getspecific(tlskey)),threadvarblocksize);
  189. end;
  190. { Include OS independent Threadvar initialization }
  191. {*****************************************************************************
  192. Thread starting
  193. *****************************************************************************}
  194. type
  195. pthreadinfo = ^tthreadinfo;
  196. tthreadinfo = record
  197. f : tthreadfunc;
  198. p : pointer;
  199. stklen : cardinal;
  200. end;
  201. function ThreadMain(param : pointer) : pointer;cdecl;
  202. var
  203. ti : tthreadinfo;
  204. nset: tsigset;
  205. {$if defined(linux) and not defined(FPC_USE_LIBC)}
  206. nlibcset: tlibc_sigset;
  207. {$endif linux/no FPC_USE_LIBC}
  208. {$ifdef DEBUG_MT}
  209. // in here, don't use write/writeln before having called
  210. // InitThread! I wonder if anyone ever debugged these routines,
  211. // because they will have crashed if DEBUG_MT was enabled!
  212. // this took me the good part of an hour to figure out
  213. // why it was crashing all the time!
  214. // this is kind of a workaround, we simply write(2) to fd 0
  215. s: string[100]; // not an ansistring
  216. {$endif DEBUG_MT}
  217. begin
  218. {$ifdef DEBUG_MT}
  219. s := 'New thread started, initing threadvars'#10;
  220. fpwrite(0,s[1],length(s));
  221. {$endif DEBUG_MT}
  222. { unblock all signals we are interested in (may be blocked by }
  223. { default in new threads on some OSes, see #9073) }
  224. fpsigemptyset(nset);
  225. fpsigaddset(nset,SIGSEGV);
  226. fpsigaddset(nset,SIGBUS);
  227. fpsigaddset(nset,SIGFPE);
  228. fpsigaddset(nset,SIGILL);
  229. {$if defined(linux) and not defined(FPC_USE_LIBC)}
  230. { sigset_t has a different size for linux/kernel and linux/libc }
  231. fillchar(nlibcset,sizeof(nlibcset),0);
  232. if (sizeof(nlibcset)>sizeof(nset)) then
  233. move(nset,nlibcset,sizeof(nset))
  234. else
  235. move(nset,nlibcset,sizeof(nlibcset));
  236. pthread_sigmask(SIG_UNBLOCK,@nlibcset,nil);
  237. {$else linux}
  238. pthread_sigmask(SIG_UNBLOCK,@nset,nil);
  239. {$endif linux}
  240. { Allocate local thread vars, this must be the first thing,
  241. because the exception management and io depends on threadvars }
  242. CAllocateThreadVars;
  243. { Copy parameter to local data }
  244. {$ifdef DEBUG_MT}
  245. s := 'New thread started, initialising ...'#10;
  246. fpwrite(0,s[1],length(s));
  247. {$endif DEBUG_MT}
  248. ti:=pthreadinfo(param)^;
  249. dispose(pthreadinfo(param));
  250. { Initialize thread }
  251. InitThread(ti.stklen);
  252. { Start thread function }
  253. {$ifdef DEBUG_MT}
  254. writeln('Jumping to thread function');
  255. {$endif DEBUG_MT}
  256. ThreadMain:=pointer(ti.f(ti.p));
  257. DoneThread;
  258. pthread_exit(ThreadMain);
  259. end;
  260. var
  261. TLSInitialized : longbool = FALSE;
  262. Procedure InitCTLS;
  263. begin
  264. if (InterLockedExchange(longint(TLSInitialized),ord(true)) = 0) then
  265. begin
  266. { We're still running in single thread mode, setup the TLS }
  267. pthread_key_create(@TLSKey,nil);
  268. InitThreadVars(@CRelocateThreadvar);
  269. { used to clean up threads that we did not create ourselves:
  270. a) the default value for a key (and hence also this one) in
  271. new threads is NULL, and if it's still like that when the
  272. thread terminates, nothing will happen
  273. b) if it's non-NULL, the destructor routine will be called
  274. when the thread terminates
  275. -> we will set it to 1 if the threadvar relocation routine is
  276. called from a thread we did not create, so that we can
  277. clean up everything at the end }
  278. pthread_key_create(@CleanupKey,@CthreadCleanup);
  279. end
  280. end;
  281. function CBeginThread(sa : Pointer;stacksize : PtrUInt;
  282. ThreadFunction : tthreadfunc;p : pointer;
  283. creationFlags : dword; var ThreadId : TThreadId) : TThreadID;
  284. var
  285. ti : pthreadinfo;
  286. thread_attr : pthread_attr_t;
  287. begin
  288. {$ifdef DEBUG_MT}
  289. writeln('Creating new thread');
  290. {$endif DEBUG_MT}
  291. { Initialize multithreading if not done }
  292. if not TLSInitialized then
  293. InitCTLS;
  294. IsMultiThread:=true;
  295. { the only way to pass data to the newly created thread
  296. in a MT safe way, is to use the heap }
  297. new(ti);
  298. ti^.f:=ThreadFunction;
  299. ti^.p:=p;
  300. ti^.stklen:=stacksize;
  301. { call pthread_create }
  302. {$ifdef DEBUG_MT}
  303. writeln('Starting new thread');
  304. {$endif DEBUG_MT}
  305. pthread_attr_init(@thread_attr);
  306. {$if not defined(HAIKU)and not defined(BEOS) and not defined(ANDROID)}
  307. {$if defined (solaris) or defined (netbsd) }
  308. pthread_attr_setinheritsched(@thread_attr, PTHREAD_INHERIT_SCHED);
  309. {$else not solaris}
  310. pthread_attr_setinheritsched(@thread_attr, PTHREAD_EXPLICIT_SCHED);
  311. {$endif not solaris}
  312. {$ifend}
  313. // will fail under linux -- apparently unimplemented
  314. pthread_attr_setscope(@thread_attr, PTHREAD_SCOPE_PROCESS);
  315. // don't create detached, we need to be able to join (waitfor) on
  316. // the newly created thread!
  317. //pthread_attr_setdetachstate(@thread_attr, PTHREAD_CREATE_DETACHED);
  318. // set the stack size
  319. if (pthread_attr_setstacksize(@thread_attr, stacksize)<>0) or
  320. // and create the thread
  321. (pthread_create(ppthread_t(@threadid), @thread_attr, @ThreadMain,ti) <> 0) then
  322. begin
  323. dispose(ti);
  324. threadid := TThreadID(0);
  325. end;
  326. CBeginThread:=threadid;
  327. pthread_attr_destroy(@thread_attr);
  328. {$ifdef DEBUG_MT}
  329. writeln('BeginThread returning ',ptrint(CBeginThread));
  330. {$endif DEBUG_MT}
  331. end;
  332. procedure CEndThread(ExitCode : DWord);
  333. begin
  334. DoneThread;
  335. pthread_detach(pthread_t(pthread_self()));
  336. pthread_exit(pointer(ptrint(ExitCode)));
  337. end;
  338. function CSuspendThread (threadHandle : TThreadID) : dword;
  339. begin
  340. { pthread_kill(SIGSTOP) cannot be used, because posix-compliant
  341. implementations then freeze the entire process instead of only
  342. the target thread. Suspending a particular thread is not
  343. supported by posix nor by most *nix implementations, presumably
  344. because of concerns mentioned in E.4 at
  345. http://pauillac.inria.fr/~xleroy/linuxthreads/faq.html#E and in
  346. http://java.sun.com/j2se/1.4.2/docs/guide/misc/threadPrimitiveDeprecation.html
  347. }
  348. // result := pthread_kill(threadHandle,SIGSTOP);
  349. result:=dword(-1);
  350. end;
  351. function CResumeThread (threadHandle : TThreadID) : dword;
  352. begin
  353. result:=dword(-1);
  354. end;
  355. procedure sched_yield; cdecl; external 'c' name 'sched_yield';
  356. procedure CThreadSwitch; {give time to other threads}
  357. begin
  358. { At least on Mac OS X, the pthread_yield_np calls through to this. }
  359. { Further, sched_yield is in POSIX and supported on FreeBSD 4+, }
  360. { Linux, Mac OS X and Solaris, while the thread-specific yield }
  361. { routines are called differently everywhere and non-standard. }
  362. sched_yield;
  363. end;
  364. function CKillThread (threadHandle : TThreadID) : dword;
  365. begin
  366. pthread_detach(pthread_t(threadHandle));
  367. {$ifndef android}
  368. CKillThread := pthread_cancel(pthread_t(threadHandle));
  369. {$else}
  370. CKillThread := dword(-1);
  371. {$endif}
  372. end;
  373. function CCloseThread (threadHandle : TThreadID) : dword;
  374. begin
  375. result:=0;
  376. end;
  377. function CWaitForThreadTerminate (threadHandle : TThreadID; TimeoutMs : longint) : dword; {0=no timeout}
  378. var
  379. LResultP: Pointer;
  380. begin
  381. pthread_join(pthread_t(threadHandle), @LResultP);
  382. CWaitForThreadTerminate := dword(LResultP);
  383. end;
  384. function CThreadSetPriority (threadHandle : TThreadID; Prio: longint): boolean; {-15..+15, 0=normal}
  385. begin
  386. {$Warning ThreadSetPriority needs to be implemented}
  387. result:=false;
  388. end;
  389. function CThreadGetPriority (threadHandle : TThreadID): Integer;
  390. begin
  391. {$Warning ThreadGetPriority needs to be implemented}
  392. result:=0;
  393. end;
  394. function CGetCurrentThreadId : TThreadID;
  395. begin
  396. CGetCurrentThreadId := TThreadID (pthread_self());
  397. end;
  398. {*****************************************************************************
  399. Delphi/Win32 compatibility
  400. *****************************************************************************}
  401. procedure CInitCriticalSection(var CS);
  402. var
  403. MAttr : pthread_mutexattr_t;
  404. res: longint;
  405. begin
  406. res:=pthread_mutexattr_init(@MAttr);
  407. if res=0 then
  408. begin
  409. res:=pthread_mutexattr_settype(@MAttr,longint(_PTHREAD_MUTEX_RECURSIVE));
  410. if res=0 then
  411. res := pthread_mutex_init(@CS,@MAttr)
  412. else
  413. { No recursive mutex support :/ }
  414. fpc_threaderror
  415. end
  416. else
  417. res:= pthread_mutex_init(@CS,NIL);
  418. pthread_mutexattr_destroy(@MAttr);
  419. if res <> 0 then
  420. fpc_threaderror;
  421. end;
  422. procedure CEnterCriticalSection(var CS);
  423. begin
  424. if pthread_mutex_lock(@CS) <> 0 then
  425. fpc_threaderror
  426. end;
  427. function CTryEnterCriticalSection(var CS):longint;
  428. begin
  429. if pthread_mutex_Trylock(@CS)=0 then
  430. result:=1 // succes
  431. else
  432. result:=0; // failure
  433. end;
  434. procedure CLeaveCriticalSection(var CS);
  435. begin
  436. if pthread_mutex_unlock(@CS) <> 0 then
  437. fpc_threaderror
  438. end;
  439. procedure CDoneCriticalSection(var CS);
  440. begin
  441. { unlock as long as unlocking works to unlock it if it is recursive
  442. some Delphi code might call this function with a locked mutex }
  443. while pthread_mutex_unlock(@CS)=0 do
  444. ;
  445. if pthread_mutex_destroy(@CS) <> 0 then
  446. fpc_threaderror;
  447. end;
  448. {*****************************************************************************
  449. Semaphore routines
  450. *****************************************************************************}
  451. type
  452. TPthreadCondition = pthread_cond_t;
  453. TPthreadMutex = pthread_mutex_t;
  454. Tbasiceventstate=record
  455. FCondVar: TPthreadCondition;
  456. FEventSection: TPthreadMutex;
  457. FWaiters: longint;
  458. FIsSet,
  459. FManualReset,
  460. FDestroying : Boolean;
  461. end;
  462. plocaleventstate = ^tbasiceventstate;
  463. // peventstate=pointer;
  464. Const
  465. wrSignaled = 0;
  466. wrTimeout = 1;
  467. wrAbandoned= 2;
  468. wrError = 3;
  469. function IntBasicEventCreate(EventAttributes : Pointer; AManualReset,InitialState : Boolean;const Name : ansistring):pEventState;
  470. var
  471. MAttr : pthread_mutexattr_t;
  472. res : cint;
  473. begin
  474. new(plocaleventstate(result));
  475. plocaleventstate(result)^.FManualReset:=AManualReset;
  476. plocaleventstate(result)^.FWaiters:=0;
  477. plocaleventstate(result)^.FDestroying:=False;
  478. plocaleventstate(result)^.FIsSet:=InitialState;
  479. res := pthread_cond_init(@plocaleventstate(result)^.FCondVar, nil);
  480. if (res <> 0) then
  481. begin
  482. FreeMem(result);
  483. fpc_threaderror;
  484. end;
  485. res:=pthread_mutexattr_init(@MAttr);
  486. if res=0 then
  487. begin
  488. res:=pthread_mutexattr_settype(@MAttr,longint(_PTHREAD_MUTEX_RECURSIVE));
  489. if Res=0 then
  490. Res:=pthread_mutex_init(@plocaleventstate(result)^.feventsection,@MAttr)
  491. else
  492. res:=pthread_mutex_init(@plocaleventstate(result)^.feventsection,nil);
  493. end
  494. else
  495. res:=pthread_mutex_init(@plocaleventstate(result)^.feventsection,nil);
  496. pthread_mutexattr_destroy(@MAttr);
  497. if res <> 0 then
  498. begin
  499. pthread_cond_destroy(@plocaleventstate(result)^.FCondVar);
  500. FreeMem(result);
  501. fpc_threaderror;
  502. end;
  503. end;
  504. procedure Intbasiceventdestroy(state:peventstate);
  505. begin
  506. { safely mark that we are destroying this event }
  507. pthread_mutex_lock(@plocaleventstate(state)^.feventsection);
  508. plocaleventstate(state)^.FDestroying:=true;
  509. { send a signal to all threads that are waiting }
  510. pthread_cond_broadcast(@plocaleventstate(state)^.FCondVar);
  511. pthread_mutex_unlock(@plocaleventstate(state)^.feventsection);
  512. { now wait until they've finished their business }
  513. while (plocaleventstate(state)^.FWaiters <> 0) do
  514. cThreadSwitch;
  515. { and clean up }
  516. pthread_cond_destroy(@plocaleventstate(state)^.Fcondvar);
  517. pthread_mutex_destroy(@plocaleventstate(state)^.FEventSection);
  518. dispose(plocaleventstate(state));
  519. end;
  520. procedure IntbasiceventResetEvent(state:peventstate);
  521. begin
  522. pthread_mutex_lock(@plocaleventstate(state)^.feventsection);
  523. plocaleventstate(state)^.fisset:=false;
  524. pthread_mutex_unlock(@plocaleventstate(state)^.feventsection);
  525. end;
  526. procedure IntbasiceventSetEvent(state:peventstate);
  527. begin
  528. pthread_mutex_lock(@plocaleventstate(state)^.feventsection);
  529. plocaleventstate(state)^.Fisset:=true;
  530. if not(plocaleventstate(state)^.FManualReset) then
  531. pthread_cond_signal(@plocaleventstate(state)^.Fcondvar)
  532. else
  533. pthread_cond_broadcast(@plocaleventstate(state)^.Fcondvar);
  534. pthread_mutex_unlock(@plocaleventstate(state)^.feventsection);
  535. end;
  536. function IntbasiceventWaitFor(Timeout : Cardinal;state:peventstate) : longint;
  537. var
  538. timespec: ttimespec;
  539. errres: cint;
  540. isset: boolean;
  541. tnow : timeval;
  542. begin
  543. { safely check whether we are being destroyed, if so immediately return. }
  544. { otherwise (under the same mutex) increase the number of waiters }
  545. pthread_mutex_lock(@plocaleventstate(state)^.feventsection);
  546. if (plocaleventstate(state)^.FDestroying) then
  547. begin
  548. pthread_mutex_unlock(@plocaleventstate(state)^.feventsection);
  549. result := wrAbandoned;
  550. exit;
  551. end;
  552. { not a regular inc() because it may happen simulatneously with the }
  553. { interlockeddecrement() at the end }
  554. interlockedincrement(plocaleventstate(state)^.FWaiters);
  555. //Wait without timeout using pthread_cond_wait
  556. if Timeout = $FFFFFFFF then
  557. begin
  558. while (not plocaleventstate(state)^.FIsSet) and (not plocaleventstate(state)^.FDestroying) do
  559. pthread_cond_wait(@plocaleventstate(state)^.Fcondvar, @plocaleventstate(state)^.feventsection);
  560. end
  561. else
  562. begin
  563. //Wait with timeout using pthread_cond_timedwait
  564. fpgettimeofday(@tnow,nil);
  565. timespec.tv_sec := tnow.tv_sec + (clong(timeout) div 1000);
  566. timespec.tv_nsec := (clong(timeout) mod 1000)*1000000 + tnow.tv_usec*1000;
  567. if timespec.tv_nsec >= 1000000000 then
  568. begin
  569. inc(timespec.tv_sec);
  570. dec(timespec.tv_nsec, 1000000000);
  571. end;
  572. errres:=0;
  573. while (not plocaleventstate(state)^.FDestroying) and (not plocaleventstate(state)^.FIsSet) and (errres<>ESysETIMEDOUT) do
  574. errres:=pthread_cond_timedwait(@plocaleventstate(state)^.Fcondvar, @plocaleventstate(state)^.feventsection, @timespec);
  575. end;
  576. isset := plocaleventstate(state)^.FIsSet;
  577. { if ManualReset=false, reset the event immediately. }
  578. if (plocaleventstate(state)^.FManualReset=false) then
  579. plocaleventstate(state)^.FIsSet := false;
  580. //check the results...
  581. if plocaleventstate(state)^.FDestroying then
  582. Result := wrAbandoned
  583. else
  584. if IsSet then
  585. Result := wrSignaled
  586. else
  587. begin
  588. if errres=ESysETIMEDOUT then
  589. Result := wrTimeout
  590. else
  591. Result := wrError;
  592. end;
  593. pthread_mutex_unlock(@plocaleventstate(state)^.feventsection);
  594. { don't put this above the previous pthread_mutex_unlock, because }
  595. { otherwise we can get errors in case an object is destroyed between }
  596. { end of the wait/sleep loop and the signalling above. }
  597. { The pthread_mutex_unlock above takes care of the memory barrier }
  598. interlockeddecrement(plocaleventstate(state)^.FWaiters);
  599. end;
  600. function intRTLEventCreate: PRTLEvent;
  601. var p:pintrtlevent;
  602. begin
  603. new(p);
  604. if not assigned(p) then
  605. fpc_threaderror;
  606. if pthread_cond_init(@p^.condvar, nil)<>0 then
  607. begin
  608. dispose(p);
  609. fpc_threaderror;
  610. end;
  611. if pthread_mutex_init(@p^.mutex, nil)<>0 then
  612. begin
  613. pthread_cond_destroy(@p^.condvar);
  614. dispose(p);
  615. fpc_threaderror;
  616. end;
  617. p^.isset:=false;
  618. result:=PRTLEVENT(p);
  619. end;
  620. procedure intRTLEventDestroy(AEvent: PRTLEvent);
  621. var p:pintrtlevent;
  622. begin
  623. p:=pintrtlevent(aevent);
  624. pthread_cond_destroy(@p^.condvar);
  625. pthread_mutex_destroy(@p^.mutex);
  626. dispose(p);
  627. end;
  628. procedure intRTLEventSetEvent(AEvent: PRTLEvent);
  629. var p:pintrtlevent;
  630. begin
  631. p:=pintrtlevent(aevent);
  632. pthread_mutex_lock(@p^.mutex);
  633. p^.isset:=true;
  634. pthread_cond_signal(@p^.condvar);
  635. pthread_mutex_unlock(@p^.mutex);
  636. end;
  637. procedure intRTLEventResetEvent(AEvent: PRTLEvent);
  638. var p:pintrtlevent;
  639. begin
  640. p:=pintrtlevent(aevent);
  641. pthread_mutex_lock(@p^.mutex);
  642. p^.isset:=false;
  643. pthread_mutex_unlock(@p^.mutex);
  644. end;
  645. procedure intRTLEventWaitFor(AEvent: PRTLEvent);
  646. var p:pintrtlevent;
  647. begin
  648. p:=pintrtlevent(aevent);
  649. pthread_mutex_lock(@p^.mutex);
  650. while not p^.isset do pthread_cond_wait(@p^.condvar, @p^.mutex);
  651. p^.isset:=false;
  652. pthread_mutex_unlock(@p^.mutex);
  653. end;
  654. procedure intRTLEventWaitForTimeout(AEvent: PRTLEvent;timeout : longint);
  655. var
  656. p : pintrtlevent;
  657. errres : cint;
  658. timespec : ttimespec;
  659. tnow : timeval;
  660. begin
  661. p:=pintrtlevent(aevent);
  662. fpgettimeofday(@tnow,nil);
  663. timespec.tv_sec:=tnow.tv_sec+(timeout div 1000);
  664. timespec.tv_nsec:=(timeout mod 1000)*1000000 + tnow.tv_usec*1000;
  665. if timespec.tv_nsec >= 1000000000 then
  666. begin
  667. inc(timespec.tv_sec);
  668. dec(timespec.tv_nsec, 1000000000);
  669. end;
  670. errres:=0;
  671. pthread_mutex_lock(@p^.mutex);
  672. while (not p^.isset) and
  673. (errres <> ESysETIMEDOUT) do
  674. begin
  675. errres:=pthread_cond_timedwait(@p^.condvar, @p^.mutex, @timespec);
  676. end;
  677. p^.isset:=false;
  678. pthread_mutex_unlock(@p^.mutex);
  679. end;
  680. type
  681. threadmethod = procedure of object;
  682. Function CInitThreads : Boolean;
  683. begin
  684. {$ifdef DEBUG_MT}
  685. Writeln('Entering InitThreads.');
  686. {$endif}
  687. {$ifndef dynpthreads}
  688. Result:=True;
  689. {$else}
  690. Result:=LoadPthreads;
  691. {$endif}
  692. ThreadID := TThreadID (pthread_self());
  693. {$ifdef DEBUG_MT}
  694. Writeln('InitThreads : ',Result);
  695. {$endif DEBUG_MT}
  696. // We assume that if you set the thread manager, the application is multithreading.
  697. InitCTLS;
  698. end;
  699. Function CDoneThreads : Boolean;
  700. begin
  701. {$ifndef dynpthreads}
  702. Result:=True;
  703. {$else}
  704. Result:=UnloadPthreads;
  705. {$endif}
  706. end;
  707. Var
  708. CThreadManager : TThreadManager;
  709. Procedure SetCThreadManager;
  710. begin
  711. With CThreadManager do begin
  712. InitManager :=@CInitThreads;
  713. DoneManager :=@CDoneThreads;
  714. BeginThread :=@CBeginThread;
  715. EndThread :=@CEndThread;
  716. SuspendThread :=@CSuspendThread;
  717. ResumeThread :=@CResumeThread;
  718. KillThread :=@CKillThread;
  719. ThreadSwitch :=@CThreadSwitch;
  720. CloseThread :=@CCloseThread;
  721. WaitForThreadTerminate :=@CWaitForThreadTerminate;
  722. ThreadSetPriority :=@CThreadSetPriority;
  723. ThreadGetPriority :=@CThreadGetPriority;
  724. GetCurrentThreadId :=@CGetCurrentThreadId;
  725. InitCriticalSection :=@CInitCriticalSection;
  726. DoneCriticalSection :=@CDoneCriticalSection;
  727. EnterCriticalSection :=@CEnterCriticalSection;
  728. TryEnterCriticalSection:=@CTryEnterCriticalSection;
  729. LeaveCriticalSection :=@CLeaveCriticalSection;
  730. InitThreadVar :=@CInitThreadVar;
  731. RelocateThreadVar :=@CRelocateThreadVar;
  732. AllocateThreadVars :=@CAllocateThreadVars;
  733. ReleaseThreadVars :=@CReleaseThreadVars;
  734. BasicEventCreate :=@intBasicEventCreate;
  735. BasicEventDestroy :=@intBasicEventDestroy;
  736. BasicEventResetEvent :=@intBasicEventResetEvent;
  737. BasicEventSetEvent :=@intBasicEventSetEvent;
  738. BasiceventWaitFor :=@intBasiceventWaitFor;
  739. rtlEventCreate :=@intrtlEventCreate;
  740. rtlEventDestroy :=@intrtlEventDestroy;
  741. rtlEventSetEvent :=@intrtlEventSetEvent;
  742. rtlEventResetEvent :=@intrtlEventResetEvent;
  743. rtleventWaitForTimeout :=@intrtleventWaitForTimeout;
  744. rtleventWaitFor :=@intrtleventWaitFor;
  745. end;
  746. SetThreadManager(CThreadManager);
  747. end;
  748. initialization
  749. if ThreadingAlreadyUsed then
  750. begin
  751. writeln('Threading has been used before cthreads was initialized.');
  752. writeln('Make cthreads one of the first units in your uses clause.');
  753. runerror(211);
  754. end;
  755. SetCThreadManager;
  756. finalization
  757. end.