paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-04 08:19:36 +01:00
Code Issues Packages Projects Releases Wiki Activity

+ Support multithreaded windows executables inCheckPointer function

Browse Source 
git-svn-id: trunk@20181 -
This commit is contained in:
pierre 2012-01-26 13:52:51 +00:00
parent f80bc70707
commit 00ca9b4ce5
1 changed files with 17 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
rtl/inc/heaptrc.pp
View File

@ -946,6 +946,11 @@ var
edata : ptruint; external name '__data_end__';
sbss : ptruint; external name '__bss_start__';
ebss : ptruint; external name '__bss_end__';
TLSKey : DWord; external name '_FPC_TlsKey';
TLSSize : DWord; external name '_FPC_TlsSize';
function TlsGetValue(dwTlsIndex : DWord) : pointer;
{$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'TlsGetValue';
{$endif}
{$ifdef BEOS}
@ -968,6 +973,9 @@ var
get_ebp,stack_top : longword;
bss_end : longword;
{$endif go32v2}
{$ifdef windows}
datap : pointer;
{$endif windows}
{$ifdef morphos}
stack_top: longword;
{$endif morphos}
@ -1016,6 +1024,14 @@ begin
{ inside bss ? }
if (ptruint(p)>=ptruint(@sbss)) and (ptruint(p)<ptruint(@ebss)) then
goto _exit;
{ is program multi-threaded and p inside Threadvar range? }
if TlsKey<>-1 then
begin
datap:=TlsGetValue(tlskey);
if ((ptruint(p)>=ptruint(datap)) and
(ptruint(p)<ptruint(datap)+TlsSize)) then
goto _exit;
end;
{$endif windows}
{$IFDEF OS2}
@ -1120,7 +1136,7 @@ begin
end;
end;
writeln(ptext^,'pointer $',hexstr(p),' does not point to valid memory block');
dump_error(p,ptext^);
dump_stack(ptext^,get_caller_frame(get_frame));
runerror(204);
_exit:
end;