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
|
{
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
*****************************************************************************}
type
pltvInitEntry = ^ltvInitEntry;
ltvInitEntry = packed record
varaddr : pdword;
size : longint;
end;
TltvInitTablesTable = packed record
count : dword;
tables : packed array [1..32767] of pltvInitEntry;
end;
PltvInitTablesTable = ^TltvInitTablesTable;
{$ifndef FPC_HAS_INDIRECT_MAIN_INFORMATION}
var
ThreadvarTablesTable : TltvInitTablesTable; external name 'FPC_THREADVARTABLES';
{$endif FPC_HAS_INDIRECT_MAIN_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 : integer;
begin
{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}
with PltvInitTablesTable(EntryInformation.ThreadvarTablesTable)^ do
{$else FPC_HAS_INDIRECT_MAIN_INFORMATION}
with ThreadvarTablesTable do
{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
begin
{$ifdef DEBUG_MT}
WriteLn ('init_all_unit_threadvars (',count,') units');
{$endif}
for i := 1 to count do
init_unit_threadvars (tables[i]);
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 : integer;
begin
{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}
with PltvInitTablesTable(EntryInformation.ThreadvarTablesTable)^ do
{$else FPC_HAS_INDIRECT_MAIN_INFORMATION}
with ThreadvarTablesTable do
{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
begin
{$ifdef DEBUG_MT}
WriteLn ('copy_all_unit_threadvars (',count,') units');
{$endif}
for i := 1 to count do
copy_unit_threadvars (tables[i]);
end;
end;
procedure InitThreadVars(RelocProc : Pointer);
begin
{ 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;
{$ifdef FPC_HAS_FEATURE_HEAP}
{$ifndef HAS_MEMORYMANAGER}
RelocateHeap;
{$endif HAS_MEMORYMANAGER}
{$endif}
end;
|
