bethreads.pp 15 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519
  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. BeOS (bethreads) 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. unit bethreads;
  14. interface
  15. {$S-}
  16. Procedure SetBeThreadManager;
  17. implementation
  18. Uses
  19. systhrds,
  20. BaseUnix,
  21. unix,
  22. unixtype,
  23. sysutils;
  24. {*****************************************************************************
  25. Generic overloaded
  26. *****************************************************************************}
  27. { Include OS specific parts. }
  28. {*****************************************************************************
  29. Threadvar support
  30. *****************************************************************************}
  31. {$ifdef HASTHREADVAR}
  32. const
  33. threadvarblocksize : dword = 0;
  34. var
  35. TLSKey : pthread_key_t;
  36. procedure BeInitThreadvar(var offset : dword;size : dword);
  37. begin
  38. offset:=threadvarblocksize;
  39. inc(threadvarblocksize,size);
  40. end;
  41. function BeRelocateThreadvar(offset : dword) : pointer;
  42. begin
  43. BeRelocateThreadvar:=pthread_getspecific(tlskey)+Offset;
  44. end;
  45. procedure BeAllocateThreadVars;
  46. var
  47. dataindex : pointer;
  48. begin
  49. { we've to allocate the memory from system }
  50. { because the FPC heap management uses }
  51. { exceptions which use threadvars but }
  52. { these aren't allocated yet ... }
  53. { allocate room on the heap for the thread vars }
  54. DataIndex:=Pointer(Fpmmap(nil,threadvarblocksize,3,MAP_PRIVATE+MAP_ANONYMOUS,-1,0));
  55. FillChar(DataIndex^,threadvarblocksize,0);
  56. pthread_setspecific(tlskey,dataindex);
  57. end;
  58. procedure BeReleaseThreadVars;
  59. begin
  60. {$ifdef ver1_0}
  61. Fpmunmap(longint(pthread_getspecific(tlskey)),threadvarblocksize);
  62. {$else}
  63. Fpmunmap(pointer(pthread_getspecific(tlskey)),threadvarblocksize);
  64. {$endif}
  65. end;
  66. { Include OS independent Threadvar initialization }
  67. {$endif HASTHREADVAR}
  68. {*****************************************************************************
  69. Thread starting
  70. *****************************************************************************}
  71. type
  72. pthreadinfo = ^tthreadinfo;
  73. tthreadinfo = record
  74. f : tthreadfunc;
  75. p : pointer;
  76. stklen : cardinal;
  77. end;
  78. procedure DoneThread;
  79. begin
  80. { Release Threadvars }
  81. {$ifdef HASTHREADVAR}
  82. CReleaseThreadVars;
  83. {$endif HASTHREADVAR}
  84. end;
  85. function ThreadMain(param : pointer) : pointer;cdecl;
  86. var
  87. ti : tthreadinfo;
  88. {$ifdef DEBUG_MT}
  89. // in here, don't use write/writeln before having called
  90. // InitThread! I wonder if anyone ever debugged these routines,
  91. // because they will have crashed if DEBUG_MT was enabled!
  92. // this took me the good part of an hour to figure out
  93. // why it was crashing all the time!
  94. // this is kind of a workaround, we simply write(2) to fd 0
  95. s: string[100]; // not an ansistring
  96. {$endif DEBUG_MT}
  97. begin
  98. {$ifdef DEBUG_MT}
  99. s := 'New thread started, initing threadvars'#10;
  100. fpwrite(0,s[1],length(s));
  101. {$endif DEBUG_MT}
  102. {$ifdef HASTHREADVAR}
  103. { Allocate local thread vars, this must be the first thing,
  104. because the exception management and io depends on threadvars }
  105. CAllocateThreadVars;
  106. {$endif HASTHREADVAR}
  107. { Copy parameter to local data }
  108. {$ifdef DEBUG_MT}
  109. s := 'New thread started, initialising ...'#10;
  110. fpwrite(0,s[1],length(s));
  111. {$endif DEBUG_MT}
  112. ti:=pthreadinfo(param)^;
  113. dispose(pthreadinfo(param));
  114. { Initialize thread }
  115. InitThread(ti.stklen);
  116. { Start thread function }
  117. {$ifdef DEBUG_MT}
  118. writeln('Jumping to thread function');
  119. {$endif DEBUG_MT}
  120. ThreadMain:=pointer(ti.f(ti.p));
  121. DoneThread;
  122. pthread_detach(pthread_t(pthread_self()));
  123. end;
  124. function BeBeginThread(sa : Pointer;stacksize : dword;
  125. ThreadFunction : tthreadfunc;p : pointer;
  126. creationFlags : dword; var ThreadId : THandle) : DWord;
  127. var
  128. ti : pthreadinfo;
  129. thread_attr : pthread_attr_t;
  130. begin
  131. {$ifdef DEBUG_MT}
  132. writeln('Creating new thread');
  133. {$endif DEBUG_MT}
  134. { Initialize multithreading if not done }
  135. if not IsMultiThread then
  136. begin
  137. {$ifdef HASTHREADVAR}
  138. { We're still running in single thread mode, setup the TLS }
  139. pthread_key_create(@TLSKey,nil);
  140. InitThreadVars(@CRelocateThreadvar);
  141. {$endif HASTHREADVAR}
  142. IsMultiThread:=true;
  143. end;
  144. { the only way to pass data to the newly created thread
  145. in a MT safe way, is to use the heap }
  146. new(ti);
  147. ti^.f:=ThreadFunction;
  148. ti^.p:=p;
  149. ti^.stklen:=stacksize;
  150. { call pthread_create }
  151. {$ifdef DEBUG_MT}
  152. writeln('Starting new thread');
  153. {$endif DEBUG_MT}
  154. pthread_attr_init(@thread_attr);
  155. pthread_attr_setinheritsched(@thread_attr, PTHREAD_EXPLICIT_SCHED);
  156. // will fail under linux -- apparently unimplemented
  157. pthread_attr_setscope(@thread_attr, PTHREAD_SCOPE_PROCESS);
  158. // don't create detached, we need to be able to join (waitfor) on
  159. // the newly created thread!
  160. //pthread_attr_setdetachstate(@thread_attr, PTHREAD_CREATE_DETACHED);
  161. if pthread_create(@threadid, @thread_attr, @ThreadMain,ti) <> 0 then begin
  162. threadid := 0;
  163. end;
  164. BeBeginThread:=threadid;
  165. {$ifdef DEBUG_MT}
  166. writeln('BeginThread returning ',BeBeginThread);
  167. {$endif DEBUG_MT}
  168. end;
  169. procedure BeEndThread(ExitCode : DWord);
  170. begin
  171. DoneThread;
  172. pthread_detach(pthread_t(pthread_self()));
  173. pthread_exit(pointer(ExitCode));
  174. end;
  175. {$warning threadhandle can be larger than a dword}
  176. function BeSuspendThread (threadHandle : dword) : dword;
  177. begin
  178. {$Warning SuspendThread needs to be implemented}
  179. end;
  180. {$warning threadhandle can be larger than a dword}
  181. function BeResumeThread (threadHandle : dword) : dword;
  182. begin
  183. {$Warning ResumeThread needs to be implemented}
  184. end;
  185. procedure CThreadSwitch; {give time to other threads}
  186. begin
  187. {extern int pthread_yield (void) __THROW;}
  188. {$Warning ThreadSwitch needs to be implemented}
  189. end;
  190. {$warning threadhandle can be larger than a dword}
  191. function BeKillThread (threadHandle : dword) : dword;
  192. begin
  193. pthread_detach(pthread_t(threadHandle));
  194. CKillThread := pthread_cancel(pthread_t(threadHandle));
  195. end;
  196. {$warning threadhandle can be larger than a dword}
  197. function BeWaitForThreadTerminate (threadHandle : dword; TimeoutMs : longint) : dword; {0=no timeout}
  198. var
  199. LResultP: Pointer;
  200. LResult: DWord;
  201. begin
  202. LResult := 0;
  203. LResultP := @LResult;
  204. pthread_join(pthread_t(threadHandle), @LResultP);
  205. CWaitForThreadTerminate := LResult;
  206. end;
  207. {$warning threadhandle can be larger than a dword}
  208. function BeThreadSetPriority (threadHandle : dword; Prio: longint): boolean; {-15..+15, 0=normal}
  209. begin
  210. {$Warning ThreadSetPriority needs to be implemented}
  211. end;
  212. {$warning threadhandle can be larger than a dword}
  213. function BeThreadGetPriority (threadHandle : dword): Integer;
  214. begin
  215. {$Warning ThreadGetPriority needs to be implemented}
  216. end;
  217. {$warning threadhandle can be larger than a dword}
  218. function BeGetCurrentThreadId : dword;
  219. begin
  220. CGetCurrentThreadId:=dword(pthread_self());
  221. end;
  222. {*****************************************************************************
  223. Delphi/Win32 compatibility
  224. *****************************************************************************}
  225. procedure BeInitCriticalSection(var CS);
  226. var
  227. MAttr : pthread_mutexattr_t;
  228. res: longint;
  229. begin
  230. res:=pthread_mutexattr_init(@MAttr);
  231. if res=0 then
  232. begin
  233. res:=pthread_mutexattr_settype(@MAttr,longint(_PTHREAD_MUTEX_RECURSIVE));
  234. if res=0 then
  235. res := pthread_mutex_init(@CS,@MAttr)
  236. else
  237. { No recursive mutex support :/ }
  238. res := pthread_mutex_init(@CS,NIL);
  239. end
  240. else
  241. res:= pthread_mutex_init(@CS,NIL);
  242. pthread_mutexattr_destroy(@MAttr);
  243. if res <> 0 then
  244. runerror(6);
  245. end;
  246. procedure BeEnterCriticalSection(var CS);
  247. begin
  248. if pthread_mutex_lock(@CS) <> 0 then
  249. runerror(6);
  250. end;
  251. procedure BeLeaveCriticalSection(var CS);
  252. begin
  253. if pthread_mutex_unlock(@CS) <> 0 then
  254. runerror(6)
  255. end;
  256. procedure BeDoneCriticalSection(var CS);
  257. begin
  258. if pthread_mutex_destroy(@CS) <> 0 then
  259. runerror(6);
  260. end;
  261. {*****************************************************************************
  262. Heap Mutex Protection
  263. *****************************************************************************}
  264. var
  265. HeapMutex : pthread_mutex_t;
  266. procedure BeThreadHeapMutexInit;
  267. begin
  268. pthread_mutex_init(@heapmutex,nil);
  269. end;
  270. procedure BeThreadHeapMutexDone;
  271. begin
  272. pthread_mutex_destroy(@heapmutex);
  273. end;
  274. procedure BeThreadHeapMutexLock;
  275. begin
  276. pthread_mutex_lock(@heapmutex);
  277. end;
  278. procedure BeThreadHeapMutexUnlock;
  279. begin
  280. pthread_mutex_unlock(@heapmutex);
  281. end;
  282. const
  283. BeThreadMemoryMutexManager : TMemoryMutexManager = (
  284. MutexInit : @BeThreadHeapMutexInit;
  285. MutexDone : @BeThreadHeapMutexDone;
  286. MutexLock : @BeThreadHeapMutexLock;
  287. MutexUnlock : @BeThreadHeapMutexUnlock;
  288. );
  289. procedure InitHeapMutexes;
  290. begin
  291. SetMemoryMutexManager(BeThreadMemoryMutexManager);
  292. end;
  293. Function BeInitThreads : Boolean;
  294. begin
  295. {$ifdef DEBUG_MT}
  296. Writeln('Entering InitThreads.');
  297. {$endif}
  298. {$ifndef dynpthreads}
  299. Result:=True;
  300. {$else}
  301. Result:=LoadPthreads;
  302. {$endif}
  303. ThreadID := SizeUInt (pthread_self);
  304. {$ifdef DEBUG_MT}
  305. Writeln('InitThreads : ',Result);
  306. {$endif DEBUG_MT}
  307. end;
  308. Function BeDoneThreads : Boolean;
  309. begin
  310. {$ifndef dynpthreads}
  311. Result:=True;
  312. {$else}
  313. Result:=UnloadPthreads;
  314. {$endif}
  315. end;
  316. type
  317. TPthreadMutex = pthread_mutex_t;
  318. Tbasiceventstate=record
  319. FSem: Pointer;
  320. FManualReset: Boolean;
  321. FEventSection: TPthreadMutex;
  322. end;
  323. plocaleventstate = ^tbasiceventstate;
  324. // peventstate=pointer;
  325. Const
  326. wrSignaled = 0;
  327. wrTimeout = 1;
  328. wrAbandoned= 2;
  329. wrError = 3;
  330. function IntBasicEventCreate(EventAttributes : Pointer; AManualReset,InitialState : Boolean;const Name : ansistring):pEventState;
  331. var
  332. MAttr : pthread_mutexattr_t;
  333. res : cint;
  334. begin
  335. new(plocaleventstate(result));
  336. plocaleventstate(result)^.FManualReset:=AManualReset;
  337. plocaleventstate(result)^.FSem:=New(PSemaphore); //sem_t.
  338. // plocaleventstate(result)^.feventsection:=nil;
  339. res:=pthread_mutexattr_init(@MAttr);
  340. if res=0 then
  341. begin
  342. res:=pthread_mutexattr_settype(@MAttr,longint(_PTHREAD_MUTEX_RECURSIVE));
  343. if Res=0 then
  344. Res:=pthread_mutex_init(@plocaleventstate(result)^.feventsection,@MAttr)
  345. else
  346. res:=pthread_mutex_init(@plocaleventstate(result)^.feventsection,nil);
  347. end
  348. else
  349. res:=pthread_mutex_init(@plocaleventstate(result)^.feventsection,nil);
  350. pthread_mutexattr_destroy(@MAttr);
  351. if res <> 0 then
  352. runerror(6);
  353. if sem_init(psem_t(plocaleventstate(result)^.FSem),ord(False),Ord(InitialState)) <> 0 then
  354. runerror(6);
  355. end;
  356. procedure Intbasiceventdestroy(state:peventstate);
  357. begin
  358. sem_destroy(psem_t( plocaleventstate(state)^.FSem));
  359. end;
  360. procedure IntbasiceventResetEvent(state:peventstate);
  361. begin
  362. While sem_trywait(psem_t( plocaleventstate(state)^.FSem))=0 do
  363. ;
  364. end;
  365. procedure IntbasiceventSetEvent(state:peventstate);
  366. Var
  367. Value : Longint;
  368. begin
  369. pthread_mutex_lock(@plocaleventstate(state)^.feventsection);
  370. Try
  371. sem_getvalue(plocaleventstate(state)^.FSem,@value);
  372. if Value=0 then
  373. sem_post(psem_t( plocaleventstate(state)^.FSem));
  374. finally
  375. pthread_mutex_unlock(@plocaleventstate(state)^.feventsection);
  376. end;
  377. end;
  378. function IntbasiceventWaitFor(Timeout : Cardinal;state:peventstate) : longint;
  379. begin
  380. If TimeOut<>Cardinal($FFFFFFFF) then
  381. result:=wrError
  382. else
  383. begin
  384. sem_wait(psem_t(plocaleventstate(state)^.FSem));
  385. result:=wrSignaled;
  386. if plocaleventstate(state)^.FManualReset then
  387. begin
  388. pthread_mutex_lock(@plocaleventstate(state)^.feventsection);
  389. Try
  390. intbasiceventresetevent(State);
  391. sem_post(psem_t( plocaleventstate(state)^.FSem));
  392. Finally
  393. pthread_mutex_unlock(@plocaleventstate(state)^.feventsection);
  394. end;
  395. end;
  396. end;
  397. end;
  398. Var
  399. BeThreadManager : TThreadManager;
  400. Procedure SetBeThreadManager;
  401. begin
  402. With BeThreadManager do
  403. begin
  404. InitManager :=@BeInitThreads;
  405. DoneManager :=@BeDoneThreads;
  406. BeginThread :=@BeBeginThread;
  407. EndThread :=@BeEndThread;
  408. SuspendThread :=@BeSuspendThread;
  409. ResumeThread :=@BeResumeThread;
  410. KillThread :=@BeKillThread;
  411. ThreadSwitch :=@BeThreadSwitch;
  412. WaitForThreadTerminate :=@BeWaitForThreadTerminate;
  413. ThreadSetPriority :=@BeThreadSetPriority;
  414. ThreadGetPriority :=@BeThreadGetPriority;
  415. GetCurrentThreadId :=@BeGetCurrentThreadId;
  416. InitCriticalSection :=@BeInitCriticalSection;
  417. DoneCriticalSection :=@BeDoneCriticalSection;
  418. EnterCriticalSection :=@BeEnterCriticalSection;
  419. LeaveCriticalSection :=@BeLeaveCriticalSection;
  420. {$ifdef hasthreadvar}
  421. InitThreadVar :=@BeInitThreadVar;
  422. RelocateThreadVar :=@BeRelocateThreadVar;
  423. AllocateThreadVars :=@BeAllocateThreadVars;
  424. ReleaseThreadVars :=@BeReleaseThreadVars;
  425. {$endif}
  426. BasicEventCreate :=@intBasicEventCreate;
  427. BasicEventDestroy :=@intBasicEventDestroy;
  428. BasicEventResetEvent :=@intBasicEventResetEvent;
  429. BasicEventSetEvent :=@intBasicEventSetEvent;
  430. BasiceventWaitFor :=@intBasiceventWaitFor;
  431. end;
  432. SetThreadManager(BeThreadManager);
  433. InitHeapMutexes;
  434. end;
  435. initialization
  436. SetBeThreadManager;
  437. end.