1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
{
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by Michael Van Canneyt
member of the Free Pascal development team
Threadvar support, platform independent part
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{*****************************************************************************
Threadvar support
*****************************************************************************}
{$ifndef FPC_SECTION_THREADVARS}
type
pltvInitEntry = ^ltvInitEntry;
ppltvInitEntry = ^pltvInitEntry;
ltvInitEntry = {$ifndef FPC_ALIGNED_THREADVARTABLES}packed{$endif} record
varaddr : {$ifdef cpu16}pword{$else}pdword{$endif};
size : longint;
end;
TltvInitTablesTable = {$ifndef FPC_ALIGNED_THREADVARTABLES}packed{$endif} record
count : dword;
tables : {$ifndef FPC_ALIGNED_THREADVARTABLES}packed{$endif} array [1..{$ifdef cpu16}16{$else}32767{$endif}] of {$ifdef ver3_0}pltvInitEntry{$else}ppltvInitEntry{$endif};
end;
PltvInitTablesTable = ^TltvInitTablesTable;
{$ifndef FPC_HAS_INDIRECT_ENTRY_INFORMATION}
var
ThreadvarTablesTable : TltvInitTablesTable; external name 'FPC_THREADVARTABLES';
{$endif FPC_HAS_INDIRECT_ENTRY_INFORMATION}
procedure init_unit_threadvars (tableEntry : pltvInitEntry);
begin
while tableEntry^.varaddr <> nil do
begin
CurrentTM.InitThreadvar (tableEntry^.varaddr^, tableEntry^.size);
inc (pchar (tableEntry), sizeof (tableEntry^));
end;
end;
procedure init_all_unit_threadvars;
var
i : longint;
begin
{$ifdef FPC_HAS_INDIRECT_ENTRY_INFORMATION}
with PltvInitTablesTable(EntryInformation.ThreadvarTablesTable)^ do
{$else FPC_HAS_INDIRECT_ENTRY_INFORMATION}
with ThreadvarTablesTable do
{$endif FPC_HAS_INDIRECT_ENTRY_INFORMATION}
begin
{$ifdef DEBUG_MT}
WriteLn ('init_all_unit_threadvars (',count,') units');
{$endif}
for i := 1 to count do
init_unit_threadvars (tables[i]{$ifndef ver3_0}^{$endif});
end;
end;
procedure copy_unit_threadvars (tableEntry : pltvInitEntry);
var
oldp,
newp : pointer;
begin
while tableEntry^.varaddr <> nil do
begin
newp:=CurrentTM.RelocateThreadVar(tableEntry^.varaddr^);
oldp:=pointer(pchar(tableEntry^.varaddr)+sizeof(pointer));
move(oldp^,newp^,tableEntry^.size);
inc (pchar (tableEntry), sizeof (tableEntry^));
end;
end;
procedure copy_all_unit_threadvars;
var
i: longint;
begin
{$ifdef FPC_HAS_INDIRECT_ENTRY_INFORMATION}
with PltvInitTablesTable(EntryInformation.ThreadvarTablesTable)^ do
{$else FPC_HAS_INDIRECT_ENTRY_INFORMATION}
with ThreadvarTablesTable do
{$endif FPC_HAS_INDIRECT_ENTRY_INFORMATION}
begin
{$ifdef DEBUG_MT}
WriteLn ('copy_all_unit_threadvars (',count,') units');
{$endif}
for i := 1 to count do
copy_unit_threadvars (tables[i]{$ifndef ver3_0}^{$endif});
end;
end;
{$endif FPC_SECTION_THREADVARS}
procedure InitThreadVars(RelocProc : TRelocateThreadVarHandler);
begin
{$ifndef FPC_SECTION_THREADVARS}
{ initialize threadvars }
init_all_unit_threadvars;
{ allocate mem for main thread threadvars }
CurrentTM.AllocateThreadVars;
{ copy main thread threadvars }
copy_all_unit_threadvars;
{ install threadvar handler }
fpc_threadvar_relocate_proc:=RelocProc;
{$endif FPC_SECTION_THREADVARS}
{$ifdef FPC_HAS_FEATURE_HEAP}
{$ifndef HAS_MEMORYMANAGER}
{$ifndef FPC_NO_DEFAULT_HEAP}
RelocateHeap;
{$endif ndef FPC_NO_DEFAULT_HEAP}
{$endif HAS_MEMORYMANAGER}
{$endif}
end;
|
