123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124 |
- {
- 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;
- ppltvInitEntry = ^pltvInitEntry;
- ltvInitEntry = packed record
- varaddr : {$ifdef cpu16}pword{$else}pdword{$endif};
- size : longint;
- end;
- TltvInitTablesTable = packed record
- count : dword;
- tables : packed 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;
- procedure InitThreadVars(RelocProc : TRelocateThreadVarHandler);
- 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}
- {$ifndef FPC_NO_DEFAULT_HEAP}
- RelocateHeap;
- {$endif ndef FPC_NO_DEFAULT_HEAP}
- {$endif HAS_MEMORYMANAGER}
- {$endif}
- end;
|