← Back to branch summary

~ubuntu-branches/ubuntu/dapper/fpc/dapper

« back to all changes in this revision

Viewing changes to rtl/netwlibc/systhrd.inc

  • Committer: Bazaar Package Importer
  • Author(s): Carlos Laviola
  • Date: 2005-05-30 11:59:10 UTC
  • mfrom: (1.2.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20050530115910-x5pbzm4qqta4i94h
Tags: 2.0.0-2
http://bugs.debian.org/310907
debian/fp-compiler.postinst.in: forgot to reapply the patch that
correctly creates the slave link to pc(1).  (Closes: #310907)

Show diffs side-by-side

added added

removed removed

Lines of Context:
rtl/netwlibc/systhrd.inc
 
1
{
 
2
    $Id: systhrd.inc,v 1.2 2005/02/14 17:13:30 peter Exp $
 
3
    This file is part of the Free Pascal run time library.
 
4
    Copyright (c) 2002 by Peter Vreman,
 
5
    member of the Free Pascal development team.
 
6
 
 
7
    Linux (pthreads) threading support implementation
 
8
 
 
9
    See the file COPYING.FPC, included in this distribution,
 
10
    for details about the copyright.
 
11
 
 
12
    This program is distributed in the hope that it will be useful,
 
13
    but WITHOUT ANY WARRANTY; without even the implied warranty of
 
14
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
15
 
 
16
 **********************************************************************}
 
17
 
 
18
{ ok, so this is a hack, but it works nicely. Just never use
 
19
  a multiline argument with WRITE_DEBUG! }
 
20
{$MACRO ON}
 
21
{$IFDEF DEBUG_MT}
 
22
{$define WRITE_DEBUG := ConsolePrintf} // actually write something
 
23
{$ELSE}
 
24
{$define WRITE_DEBUG := //}      // just comment out those lines
 
25
{$ENDIF}
 
26
 
 
27
{*****************************************************************************
 
28
                             Threadvar support
 
29
*****************************************************************************}
 
30
 
 
31
{$ifdef HASTHREADVAR}
 
32
    const
 
33
      threadvarblocksize : dword = 0;
 
34
      thredvarsmainthread: pointer = nil; // to free the threadvars in the signal handler
 
35
 
 
36
 
 
37
    var
 
38
      TLSKey : pthread_key_t;
 
39
      ThVarAllocResourceTag : rtag_t;
 
40
 
 
41
    procedure SysInitThreadvar(var offset : dword;size : dword);
 
42
      begin
 
43
        offset:=threadvarblocksize;
 
44
        inc(threadvarblocksize,size);
 
45
      end;
 
46
 
 
47
    function SysRelocateThreadvar(offset : dword) : pointer;
 
48
      begin
 
49
        SysRelocateThreadvar:=pthread_getspecific(tlskey)+Offset;
 
50
      end;
 
51
 
 
52
 
 
53
    procedure SysAllocateThreadVars;
 
54
      var
 
55
        dataindex : pointer;
 
56
      begin
 
57
        { we've to allocate the memory from system  }
 
58
        { because the FPC heap management uses      }
 
59
        { exceptions which use threadvars but       }
 
60
        { these aren't allocated yet ...            }
 
61
        { allocate room on the heap for the thread vars }
 
62
        DataIndex:=_Alloc(threadvarblocksize,ThVarAllocResourceTag);
 
63
        //DataIndex:=Pointer(Fpmmap(nil,threadvarblocksize,3,MAP_PRIVATE+MAP_ANONYMOUS,-1,0));
 
64
        FillChar(DataIndex^,threadvarblocksize,0);
 
65
        pthread_setspecific(tlskey,dataindex);
 
66
        if thredvarsmainthread = nil then
 
67
          thredvarsmainthread := dataindex;
 
68
        WRITE_DEBUG ('SysAllocateThreadVars'#13#10);
 
69
      end;
 
70
 
 
71
 
 
72
    procedure SysReleaseThreadVars;
 
73
      begin
 
74
        WRITE_DEBUG ('SysReleaseThreadVars'#13#10);
 
75
        _Free (pthread_getspecific(tlskey));
 
76
      end;
 
77
 
 
78
    function SysSetThreadDataAreaPtr (newPtr:pointer):pointer;
 
79
    begin
 
80
      SysSetThreadDataAreaPtr := pthread_getspecific(tlskey);  // return current
 
81
      if newPtr = nil then                                  // if nil
 
82
        newPtr := thredvarsmainthread;                      // set main thread vars
 
83
      pthread_setspecific(tlskey,newPtr);
 
84
    end;
 
85
 
 
86
{$endif HASTHREADVAR}
 
87
 
 
88
 
 
89
{*****************************************************************************
 
90
                            Thread starting
 
91
*****************************************************************************}
 
92
 
 
93
    type
 
94
      pthreadinfo = ^tthreadinfo;
 
95
      tthreadinfo = record
 
96
        f : tthreadfunc;
 
97
        p : pointer;
 
98
        stklen : cardinal;
 
99
      end;
 
100
 
 
101
    procedure DoneThread;
 
102
      begin
 
103
        { Release Threadvars }
 
104
{$ifdef HASTHREADVAR}
 
105
        WRITE_DEBUG('DoneThread, releasing threadvars'#13#10);
 
106
        SysReleaseThreadVars;
 
107
{$endif HASTHREADVAR}
 
108
      end;
 
109
 
 
110
 
 
111
    function ThreadMain(param : pointer) : pointer;cdecl;
 
112
      var
 
113
        ti : tthreadinfo;
 
114
      begin
 
115
        WRITE_DEBUG('New thread started, initing threadvars'#13#10);
 
116
{$ifdef HASTHREADVAR}
 
117
        { Allocate local thread vars, this must be the first thing,
 
118
          because the exception management and io depends on threadvars }
 
119
        SysAllocateThreadVars;
 
120
{$endif HASTHREADVAR}
 
121
        { Copy parameter to local data }
 
122
        WRITE_DEBUG('New thread started, initialising ...'#13#10);
 
123
        ti:=pthreadinfo(param)^;
 
124
        dispose(pthreadinfo(param));
 
125
        { Initialize thread }
 
126
        InitThread(ti.stklen);
 
127
        { Start thread function }
 
128
        WRITE_DEBUG('Jumping to thread function'#13#10);
 
129
        ThreadMain:=pointer(ti.f(ti.p));
 
130
        DoneThread;
 
131
        //pthread_detach(pointer(pthread_self));
 
132
        pthread_exit (nil);
 
133
      end;
 
134
 
 
135
 
 
136
    function SysBeginThread(sa : Pointer;stacksize : dword;
 
137
                         ThreadFunction : tthreadfunc;p : pointer;
 
138
                         creationFlags : dword; var ThreadId : THandle) : DWord;
 
139
      var
 
140
        ti : pthreadinfo;
 
141
        thread_attr : pthread_attr_t;
 
142
      begin
 
143
        WRITE_DEBUG('SysBeginThread: Creating new thread'#13#10);
 
144
        { Initialize multithreading if not done }
 
145
        if not IsMultiThread then
 
146
         begin
 
147
{$ifdef HASTHREADVAR}
 
148
          { We're still running in single thread mode, setup the TLS }
 
149
           pthread_key_create(@TLSKey,nil);
 
150
           InitThreadVars(@SysRelocateThreadvar);
 
151
{$endif HASTHREADVAR}
 
152
           IsMultiThread:=true;
 
153
         end;
 
154
        { the only way to pass data to the newly created thread
 
155
          in a MT safe way, is to use the heap }
 
156
        getmem(ti,sizeof(pthreadinfo));
 
157
        ti^.f:=ThreadFunction;
 
158
        ti^.p:=p;
 
159
        ti^.stklen:=stacksize;
 
160
        { call pthread_create }
 
161
        WRITE_DEBUG('SysBeginThread: Starting new thread'#13#10);
 
162
        pthread_attr_init(@thread_attr);
 
163
        pthread_attr_setinheritsched(@thread_attr, PTHREAD_EXPLICIT_SCHED);
 
164
 
 
165
        // will fail under linux -- apparently unimplemented
 
166
        pthread_attr_setscope(@thread_attr, PTHREAD_SCOPE_PROCESS);
 
167
 
 
168
        // don't create detached, we need to be able to join (waitfor) on
 
169
        // the newly created thread!
 
170
        //pthread_attr_setdetachstate(@thread_attr, PTHREAD_CREATE_DETACHED);
 
171
        if pthread_create(@threadid, @thread_attr, @ThreadMain,ti) <> 0 then begin
 
172
          threadid := 0;
 
173
        end;
 
174
        SysBeginThread:=threadid;
 
175
        WRITE_DEBUG('SysBeginThread returning %d'#13#10,SysBeginThread);
 
176
      end;
 
177
 
 
178
 
 
179
    procedure SysEndThread(ExitCode : DWord);
 
180
      begin
 
181
        DoneThread;
 
182
        pthread_detach(pointer(pthread_self));
 
183
        pthread_exit(pointer(ExitCode));
 
184
      end;
 
185
 
 
186
 
 
187
    function  SysSuspendThread (threadHandle : dword) : dword;
 
188
    begin
 
189
      {$Warning SuspendThread needs to be implemented}
 
190
      SysSuspendThread := $0FFFFFFFF;
 
191
    end;
 
192
 
 
193
    function  SysResumeThread  (threadHandle : dword) : dword;
 
194
    begin
 
195
      {$Warning ResumeThread needs to be implemented}
 
196
      SysResumeThread := $0FFFFFFFF;
 
197
    end;
 
198
 
 
199
    procedure SysThreadSwitch;  {give time to other threads}
 
200
    begin
 
201
      pthread_yield;
 
202
    end;
 
203
 
 
204
    function  SysKillThread (threadHandle : dword) : dword;
 
205
    begin
 
206
      pthread_detach(pointer(threadHandle));
 
207
      SysKillThread := pthread_cancel(Pointer(threadHandle));
 
208
    end;
 
209
 
 
210
    function  SysWaitForThreadTerminate (threadHandle : dword; TimeoutMs : longint) : dword;  {0=no timeout}
 
211
    var
 
212
      LResultP: Pointer;
 
213
      LResult: DWord;
 
214
    begin
 
215
      LResult := 0;
 
216
      LResultP := @LResult;
 
217
      WRITE_DEBUG('SysWaitForThreadTerminate: waiting for %d, timeout %d'#13#10,threadHandle,timeoutMS);
 
218
      pthread_join(Pointer(threadHandle), @LResultP);
 
219
      SysWaitForThreadTerminate := LResult;
 
220
    end;
 
221
 
 
222
    function  SysThreadSetPriority (threadHandle : dword; Prio: longint): boolean; {-15..+15, 0=normal}
 
223
    begin
 
224
      {priority is ignored on netware}
 
225
      SysThreadSetPriority := true;
 
226
    end;
 
227
 
 
228
 
 
229
    function  SysThreadGetPriority (threadHandle : dword): longint;
 
230
    begin
 
231
      {priority is ignored on netware}
 
232
      SysThreadGetPriority := 0;
 
233
    end;
 
234
 
 
235
    function  SysGetCurrentThreadId : dword;
 
236
    begin
 
237
      SysGetCurrentThreadId:=dword(pthread_self);
 
238
    end;
 
239
 
 
240
 
 
241
{*****************************************************************************
 
242
                          Delphi/Win32 compatibility
 
243
*****************************************************************************}
 
244
 
 
245
    procedure SysInitCriticalSection(var CS);
 
246
 
 
247
    Var
 
248
      P : PRTLCriticalSection;
 
249
 
 
250
      begin
 
251
         P:=PRTLCriticalSection(@CS);
 
252
         FillChar (p^,sizeof(p^),0);
 
253
         pthread_mutex_init(P,NIL);
 
254
      end;
 
255
 
 
256
    procedure SysEnterCriticalSection(var CS);
 
257
      begin
 
258
         pthread_mutex_lock(PRTLCriticalSection(@CS));
 
259
      end;
 
260
 
 
261
    procedure SysLeaveCriticalSection(var CS);
 
262
      begin
 
263
         pthread_mutex_unlock(PRTLCriticalSection(@CS));
 
264
      end;
 
265
 
 
266
    procedure SysDoneCriticalSection(var CS);
 
267
      begin
 
268
         pthread_mutex_destroy(PRTLCriticalSection(@CS));
 
269
      end;
 
270
 
 
271
 
 
272
{*****************************************************************************
 
273
                           Heap Mutex Protection
 
274
*****************************************************************************}
 
275
 
 
276
    var
 
277
      HeapMutex : pthread_mutex_t;
 
278
 
 
279
    procedure PThreadHeapMutexInit;
 
280
      begin
 
281
         pthread_mutex_init(@heapmutex,nil);
 
282
      end;
 
283
 
 
284
    procedure PThreadHeapMutexDone;
 
285
      begin
 
286
         pthread_mutex_destroy(@heapmutex);
 
287
      end;
 
288
 
 
289
    procedure PThreadHeapMutexLock;
 
290
      begin
 
291
         pthread_mutex_lock(@heapmutex);
 
292
      end;
 
293
 
 
294
    procedure PThreadHeapMutexUnlock;
 
295
      begin
 
296
         pthread_mutex_unlock(@heapmutex);
 
297
      end;
 
298
 
 
299
    const
 
300
      PThreadMemoryMutexManager : TMemoryMutexManager = (
 
301
        MutexInit : @PThreadHeapMutexInit;
 
302
        MutexDone : @PThreadHeapMutexDone;
 
303
        MutexLock : @PThreadHeapMutexLock;
 
304
        MutexUnlock : @PThreadHeapMutexUnlock;
 
305
      );
 
306
 
 
307
    procedure InitHeapMutexes;
 
308
      begin
 
309
        SetMemoryMutexManager(PThreadMemoryMutexManager);
 
310
      end;
 
311
 
 
312
type
 
313
     Tbasiceventstate=record
 
314
         FSem: Pointer;
 
315
         FManualReset: Boolean;
 
316
         FEventSection: ppthread_mutex_t;
 
317
        end;
 
318
     plocaleventstate = ^tbasiceventstate;
 
319
//     peventstate=pointer;
 
320
 
 
321
Const
 
322
        wrSignaled = 0;
 
323
        wrTimeout  = 1;
 
324
        wrAbandoned= 2;
 
325
        wrError    = 3;
 
326
 
 
327
function IntBasicEventCreate(EventAttributes : Pointer; AManualReset,InitialState : Boolean;const Name : ansistring):pEventState;
 
328
 
 
329
var
 
330
  MAttr : pthread_mutex_attr_t;
 
331
  res   : cint;
 
332
 
 
333
 
 
334
begin
 
335
  //new(plocaleventstate(result));
 
336
  getmem (result,sizeof(plocaleventstate));
 
337
  plocaleventstate(result)^.FManualReset:=AManualReset;
 
338
  plocaleventstate(result)^.FSem:=New(PSemaphore);  //sem_t.
 
339
//  plocaleventstate(result)^.feventsection:=nil;
 
340
  res:=pthread_mutexattr_init(@MAttr);
 
341
  if Res=0 then
 
342
    try
 
343
      Res:=pthread_mutexattr_settype(@MAttr,longint(PTHREAD_MUTEX_RECURSIVE));
 
344
      if Res=0 then
 
345
        Res:=pthread_mutex_init(@plocaleventstate(result)^.feventsection,@MAttr);
 
346
    finally
 
347
      pthread_mutexattr_destroy(@MAttr);
 
348
    end;
 
349
  sem_init(psem_t(plocaleventstate(result)^.FSem),ord(False),Ord(InitialState));
 
350
end;
 
351
 
 
352
procedure Intbasiceventdestroy(state:peventstate);
 
353
 
 
354
begin
 
355
  sem_destroy(psem_t(  plocaleventstate(state)^.FSem));
 
356
end;
 
357
 
 
358
procedure IntbasiceventResetEvent(state:peventstate);
 
359
 
 
360
begin
 
361
  While sem_trywait(psem_t( plocaleventstate(state)^.FSem))=0 do
 
362
    ;
 
363
end;
 
364
 
 
365
procedure IntbasiceventSetEvent(state:peventstate);
 
366
 
 
367
Var
 
368
  Value : Longint;
 
369
 
 
370
begin
 
371
  pthread_mutex_lock(@plocaleventstate(state)^.feventsection);
 
372
  Try
 
373
    sem_getvalue(plocaleventstate(state)^.FSem,@value);
 
374
    if Value=0 then
 
375
      sem_post(psem_t( plocaleventstate(state)^.FSem));
 
376
  finally
 
377
    pthread_mutex_unlock(@plocaleventstate(state)^.feventsection);
 
378
  end;
 
379
end;
 
380
 
 
381
function IntbasiceventWaitFor(Timeout : Cardinal;state:peventstate) : longint;
 
382
 
 
383
begin
 
384
  If TimeOut<>Cardinal($FFFFFFFF) then
 
385
    result:=wrError
 
386
  else
 
387
    begin
 
388
    sem_wait(psem_t(plocaleventstate(state)^.FSem));
 
389
    result:=wrSignaled;
 
390
    if plocaleventstate(state)^.FManualReset then
 
391
      begin
 
392
        pthread_mutex_lock(@plocaleventstate(state)^.feventsection);
 
393
        Try
 
394
            intbasiceventresetevent(State);
 
395
            sem_post(psem_t( plocaleventstate(state)^.FSem));
 
396
          Finally
 
397
        pthread_mutex_unlock(@plocaleventstate(state)^.feventsection);
 
398
      end;
 
399
    end;
 
400
    end;
 
401
end;
 
402
 
 
403
Var
 
404
  NWThreadManager : TThreadManager;
 
405
 
 
406
Procedure InitSystemThreads;
 
407
 
 
408
begin
 
409
  With NWThreadManager do
 
410
  begin
 
411
    InitManager            :=nil;
 
412
    DoneManager            :=nil;
 
413
    BeginThread            :=@SysBeginThread;
 
414
    EndThread              :=@SysEndThread;
 
415
    SuspendThread          :=@SysSuspendThread;
 
416
    ResumeThread           :=@SysResumeThread;
 
417
    KillThread             :=@SysKillThread;
 
418
    ThreadSwitch           :=@SysThreadSwitch;
 
419
    WaitForThreadTerminate :=@SysWaitForThreadTerminate;
 
420
    ThreadSetPriority      :=@SysThreadSetPriority;
 
421
    ThreadGetPriority      :=@SysThreadGetPriority;
 
422
    GetCurrentThreadId     :=@SysGetCurrentThreadId;
 
423
    InitCriticalSection    :=@SysInitCriticalSection;
 
424
    DoneCriticalSection    :=@SysDoneCriticalSection;
 
425
    EnterCriticalSection   :=@SysEnterCriticalSection;
 
426
    LeaveCriticalSection   :=@SysLeaveCriticalSection;
 
427
{$ifdef hasthreadvar}
 
428
    InitThreadVar          :=@SysInitThreadVar;
 
429
    RelocateThreadVar      :=@SysRelocateThreadVar;
 
430
    AllocateThreadVars     :=@SysAllocateThreadVars;
 
431
    ReleaseThreadVars      :=@SysReleaseThreadVars;
 
432
{$endif}
 
433
    BasicEventCreate       :=@intBasicEventCreate;
 
434
    BasicEventDestroy      :=@intBasicEventDestroy;
 
435
    BasicEventResetEvent   :=@intBasicEventResetEvent;
 
436
    BasicEventSetEvent     :=@intBasicEventSetEvent;
 
437
    BasiceventWaitFor      :=@intBasiceventWaitFor;
 
438
    end;
 
439
  SetThreadManager(NWThreadManager);
 
440
  InitHeapMutexes;
 
441
  {$ifdef HASTHREADVAR}
 
442
  ThVarAllocResourceTag := AllocateResourceTag(getnlmhandle,'Threadvar Memory',AllocSignature);
 
443
  {$endif}
 
444
  NWSysSetThreadFunctions (@SysAllocateThreadVars,
 
445
                           @SysReleaseThreadVars,
 
446
                           @SysSetThreadDataAreaPtr);
 
447
end;
 
448
 
 
449
 
 
450
{
 
451
  $Log: systhrd.inc,v $
 
452
  Revision 1.2  2005/02/14 17:13:30  peter
 
453
    * truncate log
 
454
 
 
455
  Revision 1.1  2005/02/06 16:57:18  peter
 
456
    * threads for go32v2,os,emx,netware
 
457
 
 
458
  Revision 1.1  2005/02/06 13:06:20  peter
 
459
    * moved file and dir functions to sysfile/sysdir
 
460
    * win32 thread in systemunit
 
461
 
 
462
}
 
463