← Back to branch summary

~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to .pc/spell_errors.diff/components/codetools/memcheck.pas

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
http://bugs.debian.org/708695
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
.pc/spell_errors.diff/components/codetools/memcheck.pas
 
1
{ This unit is an extended heaptrc unit.
 
2
}
 
3
unit MemCheck;
 
4
 
 
5
{$MODE ObjFPC}
 
6
 
 
7
interface
 
8
 
 
9
{ define EXTRA to add more
 
10
  tests :
 
11
   - keep all memory after release and
 
12
   check by CRC value if not changed after release
 
13
   WARNING this needs extremely much memory (PM) }
 
14
 
 
15
{$DEFINE Extra}
 
16
 
 
17
{$inline off}// inline off for stack traces
 
18
 
 
19
// additions for codetools
 
20
{$DEFINE MC_Interface}
 
21
{$i memcheck_laz.inc}
 
22
{$UNDEF MC_Interface}
 
23
 
 
24
{$checkpointer off}
 
25
{$goto on}
 
26
 
 
27
{$if defined(win32) or defined(wince)}
 
28
  {$define windows}
 
29
{$endif}
 
30
 
 
31
Procedure DumpHeap;
 
32
 
 
33
{ define EXTRA to add more
 
34
  tests :
 
35
   - keep all memory after release and
 
36
   check by CRC value if not changed after release
 
37
   WARNING this needs extremely much memory (PM) }
 
38
 
 
39
type
 
40
   tFillExtraInfoProc = procedure(p : pointer);
 
41
   tdisplayextrainfoProc = procedure (var ptext : text;p : pointer);
 
42
 
 
43
{ Allows to add info pre memory block, see ppheap.pas of the compiler
 
44
  for example source }
 
45
procedure SetHeapExtraInfo(size : ptruint;fillproc : tfillextrainfoproc;displayproc : tdisplayextrainfoproc);
 
46
 
 
47
{ Redirection of the output to a file }
 
48
procedure SetHeapTraceOutput(const name : string);
 
49
 
 
50
const
 
51
  { tracing level
 
52
    splitted in two if memory is released !! }
 
53
{$ifdef EXTRA}
 
54
  tracesize = 32;
 
55
{$else EXTRA}
 
56
  tracesize = 16;
 
57
{$endif EXTRA}
 
58
  { install heaptrc memorymanager }
 
59
  useheaptrace : boolean=true;
 
60
  { less checking }
 
61
  quicktrace : boolean=false;
 
62
  { calls halt() on error by default !! }
 
63
  HaltOnError : boolean = true;
 
64
  { Halt on exit if any memory was not freed }
 
65
  HaltOnNotReleased : boolean = false;
 
66
 
 
67
  { set this to true if you suspect that memory
 
68
    is freed several times }
 
69
{$ifdef EXTRA}
 
70
  keepreleased : boolean=true;
 
71
{$else EXTRA}
 
72
  keepreleased : boolean=false;
 
73
{$endif EXTRA}
 
74
  { add a small footprint at the end of memory blocks, this
 
75
    can check for memory overwrites at the end of a block }
 
76
  add_tail : boolean = true;
 
77
  { put crc in sig
 
78
    this allows to test for writing into that part }
 
79
  usecrc : boolean = true;
 
80
 
 
81
 
 
82
implementation
 
83
 
 
84
// additions for codetools
 
85
{$DEFINE MC_ImplementationStart}
 
86
{$i memcheck_laz.inc}
 
87
{$UNDEF MC_ImplementationStart}
 
88
 
 
89
const
 
90
  { allows to add custom info in heap_mem_info, this is the size that will
 
91
    be allocated for this information }
 
92
  extra_info_size : ptruint = 0;
 
93
  exact_info_size : ptruint = 0;
 
94
  EntryMemUsed    : ptruint = 0;
 
95
  { function to fill this info up }
 
96
  fill_extra_info_proc : TFillExtraInfoProc = nil;
 
97
  display_extra_info_proc : TDisplayExtraInfoProc = nil;
 
98
  { indicates where the output will be redirected }
 
99
  { only set using environment variables          }
 
100
  outputstr : shortstring = '';
 
101
 
 
102
type
 
103
  pheap_extra_info = ^theap_extra_info;
 
104
  theap_extra_info = record
 
105
    check       : cardinal;  { used to check if the procvar is still valid }
 
106
    fillproc    : tfillextrainfoProc;
 
107
    displayproc : tdisplayextrainfoProc;
 
108
    data : record
 
109
           end;
 
110
  end;
 
111
 
 
112
  ppheap_mem_info = ^pheap_mem_info;
 
113
  pheap_mem_info = ^theap_mem_info;
 
114
 
 
115
  { warning the size of theap_mem_info
 
116
    must be a multiple of 8
 
117
    because otherwise you will get
 
118
    problems when releasing the usual memory part !!
 
119
    sizeof(theap_mem_info = 16+tracesize*4 so
 
120
    tracesize must be even !! PM }
 
121
  theap_mem_info = record
 
122
    previous,
 
123
    next     : pheap_mem_info;
 
124
    todolist : ppheap_mem_info;
 
125
    todonext : pheap_mem_info;
 
126
    size     : ptruint;
 
127
    sig      : longword;
 
128
{$ifdef EXTRA}
 
129
    release_sig : longword;
 
130
    prev_valid  : pheap_mem_info;
 
131
{$endif EXTRA}
 
132
    calls    : array [1..tracesize] of pointer;
 
133
    exact_info_size : word;
 
134
    extra_info_size : word;
 
135
    extra_info      : pheap_extra_info;
 
136
  end;
 
137
 
 
138
  pheap_info = ^theap_info;
 
139
  theap_info = record
 
140
{$ifdef EXTRA}
 
141
    heap_valid_first,
 
142
    heap_valid_last : pheap_mem_info;
 
143
{$endif EXTRA}
 
144
    heap_mem_root : pheap_mem_info;
 
145
    heap_free_todo : pheap_mem_info;
 
146
    getmem_cnt,
 
147
    freemem_cnt   : ptruint;
 
148
    getmem_size,
 
149
    freemem_size  : ptruint;
 
150
    getmem8_size,
 
151
    freemem8_size : ptruint;
 
152
    error_in_heap : boolean;
 
153
    inside_trace_getmem : boolean;
 
154
  end;
 
155
 
 
156
var
 
157
  useownfile : boolean;
 
158
  ownfile : text;
 
159
{$ifdef EXTRA}
 
160
  error_file : text;
 
161
{$endif EXTRA}
 
162
  main_orig_todolist: ppheap_mem_info;
 
163
  main_relo_todolist: ppheap_mem_info;
 
164
  orphaned_info: theap_info;
 
165
  todo_lock: trtlcriticalsection;
 
166
threadvar
 
167
  heap_info: theap_info;
 
168
 
 
169
{*****************************************************************************
 
170
                                   Crc 32
 
171
*****************************************************************************}
 
172
 
 
173
var
 
174
  Crc32Tbl : array[0..255] of longword;
 
175
 
 
176
procedure MakeCRC32Tbl;
 
177
var
 
178
  crc : longword;
 
179
  i,n : byte;
 
180
begin
 
181
  for i:=0 to 255 do
 
182
   begin
 
183
     crc:=i;
 
184
     for n:=1 to 8 do
 
185
      if odd(crc) then
 
186
       crc:=(crc shr 1) xor $edb88320
 
187
      else
 
188
       crc:=crc shr 1;
 
189
     Crc32Tbl[i]:=crc;
 
190
   end;
 
191
end;
 
192
 
 
193
 
 
194
Function UpdateCrc32(InitCrc:longword;var InBuf;InLen:ptruint):longword;
 
195
var
 
196
  i : ptruint;
 
197
  p : pchar;
 
198
begin
 
199
  p:=@InBuf;
 
200
  for i:=1 to InLen do
 
201
   begin
 
202
     InitCrc:=Crc32Tbl[byte(InitCrc) xor byte(p^)] xor (InitCrc shr 8);
 
203
     inc(p);
 
204
   end;
 
205
  UpdateCrc32:=InitCrc;
 
206
end;
 
207
 
 
208
Function calculate_sig(p : pheap_mem_info) : longword;
 
209
var
 
210
   crc : longword;
 
211
   pl : pptruint;
 
212
begin
 
213
   crc:=cardinal($ffffffff);
 
214
   crc:=UpdateCrc32(crc,p^.size,sizeof(ptruint));
 
215
   crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(ptruint));
 
216
   if p^.extra_info_size>0 then
 
217
     crc:=UpdateCrc32(crc,p^.extra_info^,p^.exact_info_size);
 
218
   if add_tail then
 
219
     begin
 
220
        { Check also 4 bytes just after allocation !! }
 
221
        pl:=pointer(p)+p^.extra_info_size+sizeof(theap_mem_info)+p^.size;
 
222
        crc:=UpdateCrc32(crc,pl^,sizeof(ptruint));
 
223
     end;
 
224
   calculate_sig:=crc;
 
225
end;
 
226
 
 
227
{$ifdef EXTRA}
 
228
Function calculate_release_sig(p : pheap_mem_info) : longword;
 
229
var
 
230
   crc : longword;
 
231
   pl : pptruint;
 
232
begin
 
233
   crc:=$ffffffff;
 
234
   crc:=UpdateCrc32(crc,p^.size,sizeof(ptruint));
 
235
   crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(ptruint));
 
236
   if p^.extra_info_size>0 then
 
237
     crc:=UpdateCrc32(crc,p^.extra_info^,p^.exact_info_size);
 
238
   { Check the whole of the whole allocation }
 
239
   pl:=pointer(p)+p^.extra_info_size+sizeof(theap_mem_info);
 
240
   crc:=UpdateCrc32(crc,pl^,p^.size);
 
241
   { Check also 4 bytes just after allocation !! }
 
242
   if add_tail then
 
243
     begin
 
244
        { Check also 4 bytes just after allocation !! }
 
245
        pl:=pointer(p)+p^.extra_info_size+sizeof(theap_mem_info)+p^.size;
 
246
        crc:=UpdateCrc32(crc,pl^,sizeof(ptruint));
 
247
     end;
 
248
   calculate_release_sig:=crc;
 
249
end;
 
250
{$endif EXTRA}
 
251
 
 
252
 
 
253
{*****************************************************************************
 
254
                                Helpers
 
255
*****************************************************************************}
 
256
 
 
257
function InternalFreeMemSize(loc_info: pheap_info; p: pointer; pp: pheap_mem_info;
 
258
  size: ptruint; release_todo_lock: boolean): ptruint; forward;
 
259
function TraceFreeMem(p: pointer): ptruint; forward;
 
260
 
 
261
procedure call_stack(pp : pheap_mem_info;var ptext : text);
 
262
var
 
263
  i  : ptruint;
 
264
begin
 
265
  writeln(ptext,'Call trace for block $',hexstr(pointer(pp)+sizeof(theap_mem_info)),' size ',pp^.size);
 
266
  for i:=1 to tracesize do
 
267
   if pp^.calls[i]<>nil then
 
268
     writeln(ptext,BackTraceStrFunc(pp^.calls[i]));
 
269
  { the check is done to be sure that the procvar is not overwritten }
 
270
  if assigned(pp^.extra_info) and
 
271
     (pp^.extra_info^.check=$12345678) and
 
272
     assigned(pp^.extra_info^.displayproc) then
 
273
   pp^.extra_info^.displayproc(ptext,@pp^.extra_info^.data);
 
274
end;
 
275
 
 
276
 
 
277
procedure call_free_stack(pp : pheap_mem_info;var ptext : text);
 
278
var
 
279
  i  : ptruint;
 
280
begin
 
281
  writeln(ptext,'Call trace for block at $',hexstr(pointer(pp)+sizeof(theap_mem_info)),' size ',pp^.size);
 
282
  for i:=1 to tracesize div 2 do
 
283
   if pp^.calls[i]<>nil then
 
284
     writeln(ptext,BackTraceStrFunc(pp^.calls[i]));
 
285
  writeln(ptext,' was released at ');
 
286
  for i:=(tracesize div 2)+1 to tracesize do
 
287
   if pp^.calls[i]<>nil then
 
288
     writeln(ptext,BackTraceStrFunc(pp^.calls[i]));
 
289
  { the check is done to be sure that the procvar is not overwritten }
 
290
  if assigned(pp^.extra_info) and
 
291
     (pp^.extra_info^.check=$12345678) and
 
292
     assigned(pp^.extra_info^.displayproc) then
 
293
   pp^.extra_info^.displayproc(ptext,@pp^.extra_info^.data);
 
294
end;
 
295
 
 
296
 
 
297
procedure dump_already_free(p : pheap_mem_info;var ptext : text);
 
298
begin
 
299
  Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' released');
 
300
  call_free_stack(p,ptext);
 
301
  Writeln(ptext,'freed again at');
 
302
  dump_stack(ptext,get_caller_frame(get_frame));
 
303
end;
 
304
 
 
305
procedure dump_error(p : pheap_mem_info;var ptext : text);
 
306
begin
 
307
  Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid');
 
308
  Writeln(ptext,'Wrong signature $',hexstr(p^.sig,8),' instead of ',hexstr(calculate_sig(p),8));
 
309
  dump_stack(ptext,get_caller_frame(get_frame));
 
310
end;
 
311
 
 
312
{$ifdef EXTRA}
 
313
procedure dump_change_after(p : pheap_mem_info;var ptext : text);
 
314
 var pp : pchar;
 
315
     i : ptruint;
 
316
begin
 
317
  Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid');
 
318
  Writeln(ptext,'Wrong release CRC $',hexstr(p^.release_sig,8),' instead of ',hexstr(calculate_release_sig(p),8));
 
319
  Writeln(ptext,'This memory was changed after call to freemem !');
 
320
  call_free_stack(p,ptext);
 
321
  pp:=pointer(p)+sizeof(theap_mem_info);
 
322
  for i:=0 to p^.size-1 do
 
323
    if byte(pp[i])<>$F0 then
 
324
      Writeln(ptext,'offset',i,':$',hexstr(i,2*sizeof(pointer)),'"',pp[i],'"');
 
325
end;
 
326
{$endif EXTRA}
 
327
 
 
328
procedure dump_wrong_size(p : pheap_mem_info;size : ptruint;var ptext : text);
 
329
begin
 
330
  Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid');
 
331
  Writeln(ptext,'Wrong size : ',p^.size,' allocated ',size,' freed');
 
332
  dump_stack(ptext,get_caller_frame(get_frame));
 
333
  { the check is done to be sure that the procvar is not overwritten }
 
334
  if assigned(p^.extra_info) and
 
335
     (p^.extra_info^.check=$12345678) and
 
336
     assigned(p^.extra_info^.displayproc) then
 
337
   p^.extra_info^.displayproc(ptext,@p^.extra_info^.data);
 
338
  call_stack(p,ptext);
 
339
end;
 
340
 
 
341
function is_in_getmem_list (loc_info: pheap_info; p : pheap_mem_info) : boolean;
 
342
var
 
343
  i  : ptruint;
 
344
  pp : pheap_mem_info;
 
345
begin
 
346
  is_in_getmem_list:=false;
 
347
  pp:=loc_info^.heap_mem_root;
 
348
  i:=0;
 
349
  while pp<>nil do
 
350
   begin
 
351
     if ((pp^.sig<>$DEADBEEF) or usecrc) and
 
352
        ((pp^.sig<>calculate_sig(pp)) or not usecrc) and
 
353
        (pp^.sig <>$AAAAAAAA) then
 
354
      begin
 
355
        if useownfile then
 
356
          writeln(ownfile,'error in linked list of heap_mem_info')
 
357
        else
 
358
          writeln(stderr,'error in linked list of heap_mem_info');
 
359
        RunError(204);
 
360
      end;
 
361
     if pp=p then
 
362
      is_in_getmem_list:=true;
 
363
     pp:=pp^.previous;
 
364
     inc(i);
 
365
     if i>loc_info^.getmem_cnt-loc_info^.freemem_cnt then begin
 
366
       if useownfile then
 
367
         writeln(ownfile,'error in linked list of heap_mem_info')
 
368
       else
 
369
         writeln(stderr,'error in linked list of heap_mem_info');
 
370
       RunError(204);
 
371
     end;
 
372
   end;
 
373
end;
 
374
 
 
375
procedure finish_heap_free_todo_list(loc_info: pheap_info);
 
376
var
 
377
  bp: pointer;
 
378
  pp: pheap_mem_info;
 
379
  list: ppheap_mem_info;
 
380
begin
 
381
  list := @loc_info^.heap_free_todo;
 
382
  repeat
 
383
    pp := list^;
 
384
    list^ := list^^.todonext;
 
385
    bp := pointer(pp)+sizeof(theap_mem_info);
 
386
    InternalFreeMemSize(loc_info,bp,pp,pp^.size,false);
 
387
  until list^ = nil;
 
388
end;
 
389
 
 
390
procedure try_finish_heap_free_todo_list(loc_info: pheap_info);
 
391
begin
 
392
  if loc_info^.heap_free_todo <> nil then
 
393
  begin
 
394
    entercriticalsection(todo_lock);
 
395
    finish_heap_free_todo_list(loc_info);
 
396
    leavecriticalsection(todo_lock);
 
397
  end;
 
398
end;
 
399
 
 
400
 
 
401
{*****************************************************************************
 
402
                               TraceGetMem
 
403
*****************************************************************************}
 
404
 
 
405
Function TraceGetMem(size:ptruint):pointer;
 
406
var
 
407
  allocsize,i : ptruint;
 
408
  oldbp,
 
409
  bp : pointer;
 
410
  pl : pdword;
 
411
  p  : pointer;
 
412
  pp : pheap_mem_info;
 
413
  loc_info: pheap_info;
 
414
begin
 
415
  loc_info := @heap_info;
 
416
  try_finish_heap_free_todo_list(loc_info);
 
417
  inc(loc_info^.getmem_size,size);
 
418
  inc(loc_info^.getmem8_size,(size+7) and not 7);
 
419
{ Do the real GetMem, but alloc also for the info block }
 
420
{$ifdef cpuarm}
 
421
  allocsize:=(size + 3) and not 3+sizeof(theap_mem_info)+extra_info_size;
 
422
{$else cpuarm}
 
423
  allocsize:=size+sizeof(theap_mem_info)+extra_info_size;
 
424
{$endif cpuarm}
 
425
  if add_tail then
 
426
    inc(allocsize,sizeof(ptruint));
 
427
  { if ReturnNilIfGrowHeapFails is true
 
428
    SysGetMem can return nil }
 
429
  p:=SysGetMem(allocsize);
 
430
  if (p=nil) then
 
431
    begin
 
432
      TraceGetMem:=nil;
 
433
      exit;
 
434
    end;
 
435
  pp:=pheap_mem_info(p);
 
436
  inc(p,sizeof(theap_mem_info));
 
437
{ Create the info block }
 
438
  pp^.sig:=$DEADBEEF;
 
439
  pp^.todolist:=@loc_info^.heap_free_todo;
 
440
  pp^.todonext:=nil;
 
441
  pp^.size:=size;
 
442
  pp^.extra_info_size:=extra_info_size;
 
443
  pp^.exact_info_size:=exact_info_size;
 
444
  {
 
445
    the end of the block contains:
 
446
    <tail>   4 bytes
 
447
    <extra_info>   X bytes
 
448
  }
 
449
  if extra_info_size>0 then
 
450
   begin
 
451
     pp^.extra_info:=pointer(pp)+allocsize-extra_info_size;
 
452
     fillchar(pp^.extra_info^,extra_info_size,0);
 
453
     pp^.extra_info^.check:=$12345678;
 
454
     pp^.extra_info^.fillproc:=fill_extra_info_proc;
 
455
     pp^.extra_info^.displayproc:=display_extra_info_proc;
 
456
     if assigned(fill_extra_info_proc) then
 
457
      begin
 
458
        loc_info^.inside_trace_getmem:=true;
 
459
        fill_extra_info_proc(@pp^.extra_info^.data);
 
460
        loc_info^.inside_trace_getmem:=false;
 
461
      end;
 
462
   end
 
463
  else
 
464
   pp^.extra_info:=nil;
 
465
  if add_tail then
 
466
    begin
 
467
      pl:=pointer(pp)+allocsize-pp^.extra_info_size-sizeof(ptruint);
 
468
{$ifdef FPC_SUPPORTS_UNALIGNED}
 
469
      unaligned(pl^):=$DEADBEEF;
 
470
{$else FPC_SUPPORTS_UNALIGNED}
 
471
      pl^:=$DEADBEEF;
 
472
{$endif FPC_SUPPORTS_UNALIGNED}
 
473
    end;
 
474
  { clear the memory }
 
475
  fillchar(p^,size,#255);
 
476
  { retrieve backtrace info }
 
477
  bp:=get_caller_frame(get_frame);
 
478
  for i:=1 to tracesize do
 
479
   begin
 
480
     pp^.calls[i]:=get_caller_addr(bp);
 
481
     oldbp:=bp;
 
482
     bp:=get_caller_frame(bp);
 
483
     if (bp<oldbp) or (bp>(StackBottom + StackLength)) then
 
484
       bp:=nil;
 
485
   end;
 
486
  { insert in the linked list }
 
487
  if loc_info^.heap_mem_root<>nil then
 
488
   loc_info^.heap_mem_root^.next:=pp;
 
489
  pp^.previous:=loc_info^.heap_mem_root;
 
490
  pp^.next:=nil;
 
491
{$ifdef EXTRA}
 
492
  pp^.prev_valid:=loc_info^.heap_valid_last;
 
493
  loc_info^.heap_valid_last:=pp;
 
494
  if not assigned(loc_info^.heap_valid_first) then
 
495
    loc_info^.heap_valid_first:=pp;
 
496
{$endif EXTRA}
 
497
  loc_info^.heap_mem_root:=pp;
 
498
  { must be changed before fill_extra_info is called
 
499
    because checkpointer can be called from within
 
500
    fill_extra_info PM }
 
501
  inc(loc_info^.getmem_cnt);
 
502
  { update the signature }
 
503
  if usecrc then
 
504
    pp^.sig:=calculate_sig(pp);
 
505
  TraceGetmem:=p;
 
506
end;
 
507
 
 
508
 
 
509
{*****************************************************************************
 
510
                                TraceFreeMem
 
511
*****************************************************************************}
 
512
 
 
513
function CheckFreeMemSize(loc_info: pheap_info; pp: pheap_mem_info;
 
514
  size, ppsize: ptruint): boolean;
 
515
var
 
516
  i: ptruint;
 
517
  bp : pointer;
 
518
  ptext : ^text;
 
519
{$ifdef EXTRA}
 
520
  pp2 : pheap_mem_info;
 
521
{$endif}
 
522
begin
 
523
  if useownfile then
 
524
    ptext:=@ownfile
 
525
  else
 
526
    ptext:=@stderr;
 
527
  inc(loc_info^.freemem_size,size);
 
528
  inc(loc_info^.freemem8_size,(size+7) and not 7);
 
529
  if not quicktrace then
 
530
    begin
 
531
      if not(is_in_getmem_list(loc_info, pp)) then
 
532
       RunError(204);
 
533
    end;
 
534
  if (pp^.sig=$AAAAAAAA) and not usecrc then
 
535
    begin
 
536
       loc_info^.error_in_heap:=true;
 
537
       dump_already_free(pp,ptext^);
 
538
       if haltonerror then halt(1);
 
539
    end
 
540
  else if ((pp^.sig<>$DEADBEEF) or usecrc) and
 
541
        ((pp^.sig<>calculate_sig(pp)) or not usecrc) then
 
542
    begin
 
543
       loc_info^.error_in_heap:=true;
 
544
       dump_error(pp,ptext^);
 
545
{$ifdef EXTRA}
 
546
       dump_error(pp,error_file);
 
547
{$endif EXTRA}
 
548
       { don't release anything in this case !! }
 
549
       if haltonerror then halt(1);
 
550
       exit;
 
551
    end
 
552
  else if pp^.size<>size then
 
553
    begin
 
554
       loc_info^.error_in_heap:=true;
 
555
       dump_wrong_size(pp,size,ptext^);
 
556
{$ifdef EXTRA}
 
557
       dump_wrong_size(pp,size,error_file);
 
558
{$endif EXTRA}
 
559
       if haltonerror then halt(1);
 
560
       { don't release anything in this case !! }
 
561
       exit;
 
562
    end;
 
563
  { now it is released !! }
 
564
  pp^.sig:=$AAAAAAAA;
 
565
  if not keepreleased then
 
566
    begin
 
567
       if pp^.next<>nil then
 
568
         pp^.next^.previous:=pp^.previous;
 
569
       if pp^.previous<>nil then
 
570
         pp^.previous^.next:=pp^.next;
 
571
       if pp=loc_info^.heap_mem_root then
 
572
         loc_info^.heap_mem_root:=loc_info^.heap_mem_root^.previous;
 
573
    end
 
574
  else
 
575
    begin
 
576
       bp:=get_caller_frame(get_frame);
 
577
       for i:=(tracesize div 2)+1 to tracesize do
 
578
        begin
 
579
          if bp<>nil then begin
 
580
            pp^.calls[i]:=get_caller_addr(bp);
 
581
            bp:=get_caller_frame(bp);
 
582
          end else begin
 
583
            pp^.calls[i]:=nil;
 
584
          end;
 
585
        end;
 
586
    end;
 
587
  inc(loc_info^.freemem_cnt);
 
588
  { clear the memory, $F0 will lead to GFP if used as pointer ! }
 
589
  fillchar((pointer(pp)+sizeof(theap_mem_info))^,size,#240);
 
590
  { this way we keep all info about all released memory !! }
 
591
  if keepreleased then
 
592
    begin
 
593
{$ifdef EXTRA}
 
594
       { We want to check if the memory was changed after release !! }
 
595
       pp^.release_sig:=calculate_release_sig(pp);
 
596
       if pp=loc_info^.heap_valid_last then
 
597
         begin
 
598
            loc_info^.heap_valid_last:=pp^.prev_valid;
 
599
            if pp=loc_info^.heap_valid_first then
 
600
              loc_info^.heap_valid_first:=nil;
 
601
            exit(false);
 
602
         end;
 
603
       pp2:=loc_info^.heap_valid_last;
 
604
       while assigned(pp2) do
 
605
         begin
 
606
            if pp2^.prev_valid=pp then
 
607
              begin
 
608
                 pp2^.prev_valid:=pp^.prev_valid;
 
609
                 if pp=loc_info^.heap_valid_first then
 
610
                   loc_info^.heap_valid_first:=pp2;
 
611
                 exit(false);
 
612
              end
 
613
            else
 
614
              pp2:=pp2^.prev_valid;
 
615
         end;
 
616
{$endif EXTRA}
 
617
       exit(false);
 
618
    end;
 
619
  CheckFreeMemSize:=true;
 
620
end;
 
621
 
 
622
function InternalFreeMemSize(loc_info: pheap_info; p: pointer; pp: pheap_mem_info;
 
623
  size: ptruint; release_todo_lock: boolean): ptruint;
 
624
var
 
625
  i,ppsize : ptruint;
 
626
  extra_size: ptruint;
 
627
  release_mem: boolean;
 
628
begin
 
629
  { save old values }
 
630
  extra_size:=pp^.extra_info_size;
 
631
  ppsize:= size+sizeof(theap_mem_info)+pp^.extra_info_size;
 
632
  if add_tail then
 
633
    inc(ppsize,sizeof(ptruint));
 
634
  { do various checking }
 
635
  release_mem := CheckFreeMemSize(loc_info, pp, size, ppsize);
 
636
  if release_todo_lock then
 
637
    leavecriticalsection(todo_lock);
 
638
  if release_mem then
 
639
  begin
 
640
    { release the normal memory at least }
 
641
    i:=SysFreeMemSize(pp,ppsize);
 
642
    { return the correct size }
 
643
    dec(i,sizeof(theap_mem_info)+extra_size);
 
644
    if add_tail then
 
645
      dec(i,sizeof(ptruint));
 
646
    InternalFreeMemSize:=i;
 
647
  end else
 
648
    InternalFreeMemSize:=size;
 
649
end;
 
650
 
 
651
function TraceFreeMemSize(p:pointer;size:ptruint):ptruint;
 
652
var
 
653
  loc_info: pheap_info;
 
654
  pp: pheap_mem_info;
 
655
  release_lock: boolean;
 
656
begin
 
657
  if p=nil then
 
658
    begin
 
659
      TraceFreeMemSize:=0;
 
660
      exit;
 
661
    end;
 
662
  loc_info:=@heap_info;
 
663
  pp:=pheap_mem_info(p-sizeof(theap_mem_info));
 
664
  release_lock:=false;
 
665
  if @loc_info^.heap_free_todo <> pp^.todolist then
 
666
  begin
 
667
    if pp^.todolist = main_orig_todolist then
 
668
      pp^.todolist := main_relo_todolist;
 
669
    entercriticalsection(todo_lock);
 
670
    release_lock:=true;
 
671
    if pp^.todolist = @orphaned_info.heap_free_todo then
 
672
    begin
 
673
      loc_info := @orphaned_info;
 
674
    end else
 
675
    if pp^.todolist <> @loc_info^.heap_free_todo then
 
676
    begin
 
677
      { allocated in different heap, push to that todolist }
 
678
      pp^.todonext := pp^.todolist^;
 
679
      pp^.todolist^ := pp;
 
680
      TraceFreeMemSize := pp^.size;
 
681
      leavecriticalsection(todo_lock);
 
682
      exit;
 
683
    end;
 
684
  end;
 
685
  TraceFreeMemSize:=InternalFreeMemSize(loc_info,p,pp,size,release_lock);
 
686
end;
 
687
 
 
688
 
 
689
function TraceMemSize(p:pointer):ptruint;
 
690
var
 
691
  pp : pheap_mem_info;
 
692
begin
 
693
  pp:=pheap_mem_info(p-sizeof(theap_mem_info));
 
694
  TraceMemSize:=pp^.size;
 
695
end;
 
696
 
 
697
 
 
698
function TraceFreeMem(p:pointer):ptruint;
 
699
var
 
700
  l  : ptruint;
 
701
  pp : pheap_mem_info;
 
702
begin
 
703
  if p=nil then
 
704
    begin
 
705
      TraceFreeMem:=0;
 
706
      exit;
 
707
    end;
 
708
  pp:=pheap_mem_info(p-sizeof(theap_mem_info));
 
709
  l:=SysMemSize(pp);
 
710
  dec(l,sizeof(theap_mem_info)+pp^.extra_info_size);
 
711
  if add_tail then
 
712
   dec(l,sizeof(ptruint));
 
713
  { this can never happend normaly }
 
714
  if pp^.size>l then
 
715
   begin
 
716
     if useownfile then
 
717
       dump_wrong_size(pp,l,ownfile)
 
718
     else
 
719
       dump_wrong_size(pp,l,stderr);
 
720
 
 
721
{$ifdef EXTRA}
 
722
     dump_wrong_size(pp,l,error_file);
 
723
{$endif EXTRA}
 
724
   end;
 
725
  TraceFreeMem:=TraceFreeMemSize(p,pp^.size);
 
726
end;
 
727
 
 
728
 
 
729
{*****************************************************************************
 
730
                                ReAllocMem
 
731
*****************************************************************************}
 
732
 
 
733
function TraceReAllocMem(var p:pointer;size:ptruint):Pointer;
 
734
var
 
735
  newP: pointer;
 
736
  allocsize,
 
737
  movesize,
 
738
  i  : ptruint;
 
739
  oldbp,
 
740
  bp : pointer;
 
741
  pl : pdword;
 
742
  pp : pheap_mem_info;
 
743
  oldsize,
 
744
  oldextrasize,
 
745
  oldexactsize : ptruint;
 
746
  old_fill_extra_info_proc : tfillextrainfoproc;
 
747
  old_display_extra_info_proc : tdisplayextrainfoproc;
 
748
  loc_info: pheap_info;
 
749
begin
 
750
{ Free block? }
 
751
  if size=0 then
 
752
   begin
 
753
     if p<>nil then
 
754
      TraceFreeMem(p);
 
755
     p:=nil;
 
756
     TraceReallocMem:=P;
 
757
     exit;
 
758
   end;
 
759
{ Allocate a new block? }
 
760
  if p=nil then
 
761
   begin
 
762
     p:=TraceGetMem(size);
 
763
     TraceReallocMem:=P;
 
764
     exit;
 
765
   end;
 
766
{ Resize block }
 
767
  loc_info:=@heap_info;
 
768
  pp:=pheap_mem_info(p-sizeof(theap_mem_info));
 
769
  { test block }
 
770
  if ((pp^.sig<>$DEADBEEF) or usecrc) and
 
771
     ((pp^.sig<>calculate_sig(pp)) or not usecrc) then
 
772
   begin
 
773
     loc_info^.error_in_heap:=true;
 
774
     if useownfile then
 
775
       dump_error(pp,ownfile)
 
776
     else
 
777
       dump_error(pp,stderr);
 
778
{$ifdef EXTRA}
 
779
     dump_error(pp,error_file);
 
780
{$endif EXTRA}
 
781
     { don't release anything in this case !! }
 
782
     if haltonerror then halt(1);
 
783
     exit;
 
784
   end;
 
785
  { save info }
 
786
  oldsize:=pp^.size;
 
787
  oldextrasize:=pp^.extra_info_size;
 
788
  oldexactsize:=pp^.exact_info_size;
 
789
  if pp^.extra_info_size>0 then
 
790
   begin
 
791
     old_fill_extra_info_proc:=pp^.extra_info^.fillproc;
 
792
     old_display_extra_info_proc:=pp^.extra_info^.displayproc;
 
793
   end;
 
794
  { Do the real ReAllocMem, but alloc also for the info block }
 
795
{$ifdef cpuarm}
 
796
  allocsize:=(size + 3) and not 3+sizeof(theap_mem_info)+pp^.extra_info_size;
 
797
{$else cpuarm}
 
798
  allocsize:=size+sizeof(theap_mem_info)+pp^.extra_info_size;
 
799
{$endif cpuarm}
 
800
  if add_tail then
 
801
   inc(allocsize,sizeof(ptruint));
 
802
  { Try to resize the block, if not possible we need to do a
 
803
    getmem, move data, freemem }
 
804
  if not SysTryResizeMem(pp,allocsize) then
 
805
   begin
 
806
     { get a new block }
 
807
     newP := TraceGetMem(size);
 
808
     { move the data }
 
809
     if newP <> nil then
 
810
      begin
 
811
        movesize:=TraceMemSize(p);
 
812
        {if the old size is larger than the new size,
 
813
         move only the new size}
 
814
        if movesize>size then
 
815
          movesize:=size;
 
816
        move(p^,newP^,movesize);
 
817
      end;
 
818
     { release p }
 
819
     traceFreeMem(p);
 
820
     { return the new pointer }
 
821
     p:=newp;
 
822
     traceReAllocMem := newp;
 
823
     exit;
 
824
   end;
 
825
{ Recreate the info block }
 
826
  pp^.sig:=$DEADBEEF;
 
827
  pp^.size:=size;
 
828
  pp^.extra_info_size:=oldextrasize;
 
829
  pp^.exact_info_size:=oldexactsize;
 
830
  { add the new extra_info and tail }
 
831
  if pp^.extra_info_size>0 then
 
832
   begin
 
833
     pp^.extra_info:=pointer(pp)+allocsize-pp^.extra_info_size;
 
834
     fillchar(pp^.extra_info^,extra_info_size,0);
 
835
     pp^.extra_info^.check:=$12345678;
 
836
     pp^.extra_info^.fillproc:=old_fill_extra_info_proc;
 
837
     pp^.extra_info^.displayproc:=old_display_extra_info_proc;
 
838
     if assigned(pp^.extra_info^.fillproc) then
 
839
      pp^.extra_info^.fillproc(@pp^.extra_info^.data);
 
840
   end
 
841
  else
 
842
   pp^.extra_info:=nil;
 
843
  if add_tail then
 
844
    begin
 
845
      pl:=pointer(pp)+allocsize-pp^.extra_info_size-sizeof(ptruint);
 
846
{$ifdef FPC_SUPPORTS_UNALIGNED}
 
847
      unaligned(pl^):=$DEADBEEF;
 
848
{$else FPC_SUPPORTS_UNALIGNED}
 
849
      pl^:=$DEADBEEF;
 
850
{$endif FPC_SUPPORTS_UNALIGNED}
 
851
    end;
 
852
  { adjust like a freemem and then a getmem, so you get correct
 
853
    results in the summary display }
 
854
  inc(loc_info^.freemem_size,oldsize);
 
855
  inc(loc_info^.freemem8_size,(oldsize+7) and not 7);
 
856
  inc(loc_info^.getmem_size,size);
 
857
  inc(loc_info^.getmem8_size,(size+7) and not 7);
 
858
  { generate new backtrace }
 
859
  bp:=get_caller_frame(get_frame);
 
860
  for i:=1 to tracesize do
 
861
   begin
 
862
     pp^.calls[i]:=get_caller_addr(bp);
 
863
     oldbp:=bp;
 
864
     bp:=get_caller_frame(bp);
 
865
     if (bp<oldbp) or (bp>(StackBottom + StackLength)) then
 
866
       bp:=nil;
 
867
   end;
 
868
  { regenerate signature }
 
869
  if usecrc then
 
870
    pp^.sig:=calculate_sig(pp);
 
871
  { return the pointer }
 
872
  p:=pointer(pp)+sizeof(theap_mem_info);
 
873
  TraceReAllocmem:=p;
 
874
end;
 
875
 
 
876
 
 
877
 
 
878
{*****************************************************************************
 
879
                              Check pointer
 
880
*****************************************************************************}
 
881
 
 
882
{$ifndef Unix}
 
883
  {$S-}
 
884
{$endif}
 
885
 
 
886
{$ifdef go32v2}
 
887
var
 
888
   __stklen : longword;external name '__stklen';
 
889
   __stkbottom : longword;external name '__stkbottom';
 
890
   edata : longword; external name 'edata';
 
891
{$endif go32v2}
 
892
 
 
893
{$ifdef linux}
 
894
var
 
895
   etext: ptruint; external name '_etext';
 
896
   eend : ptruint; external name '_end';
 
897
{$endif}
 
898
 
 
899
{$ifdef os2}
 
900
(* Currently still EMX based - possibly to be changed in the future. *)
 
901
var
 
902
   etext: ptruint; external name '_etext';
 
903
   edata : ptruint; external name '_edata';
 
904
   eend : ptruint; external name '_end';
 
905
{$endif}
 
906
 
 
907
{$ifdef windows}
 
908
var
 
909
   sdata : ptruint; external name '__data_start__';
 
910
   edata : ptruint; external name '__data_end__';
 
911
   sbss : ptruint; external name '__bss_start__';
 
912
   ebss : ptruint; external name '__bss_end__';
 
913
{$endif}
 
914
 
 
915
 
 
916
procedure CheckPointer(p : pointer); [public, alias : 'FPC_CHECKPOINTER'];
 
917
var
 
918
  i  : ptruint;
 
919
  pp : pheap_mem_info;
 
920
  loc_info: pheap_info;
 
921
{$ifdef go32v2}
 
922
  get_ebp,stack_top : longword;
 
923
  data_end : longword;
 
924
{$endif go32v2}
 
925
{$ifdef morphos}
 
926
  stack_top: longword;
 
927
{$endif morphos}
 
928
  ptext : ^text;
 
929
label
 
930
  _exit;
 
931
begin
 
932
  if p=nil then
 
933
    runerror(204);
 
934
 
 
935
  i:=0;
 
936
  loc_info:=@heap_info;
 
937
  if useownfile then
 
938
    ptext:=@ownfile
 
939
  else
 
940
    ptext:=@stderr;
 
941
 
 
942
{$ifdef go32v2}
 
943
  if ptruint(p)<$1000 then
 
944
    runerror(216);
 
945
  asm
 
946
     movl %ebp,get_ebp
 
947
     leal edata,%eax
 
948
     movl %eax,data_end
 
949
  end;
 
950
  stack_top:=__stkbottom+__stklen;
 
951
  { allow all between start of code and end of data }
 
952
  if ptruint(p)<=data_end then
 
953
    goto _exit;
 
954
  { stack can be above heap !! }
 
955
 
 
956
  if (ptruint(p)>=get_ebp) and (ptruint(p)<=stack_top) then
 
957
    goto _exit;
 
958
{$endif go32v2}
 
959
 
 
960
  { I don't know where the stack is in other OS !! }
 
961
{$ifdef windows}
 
962
  { inside stack ? }
 
963
  if (ptruint(p)>ptruint(get_frame)) and
 
964
     (p<StackTop) then
 
965
    goto _exit;
 
966
  { inside data ? }
 
967
  if (ptruint(p)>=ptruint(@sdata)) and (ptruint(p)<ptruint(@edata)) then
 
968
    goto _exit;
 
969
 
 
970
  { inside bss ? }
 
971
  if (ptruint(p)>=ptruint(@sbss)) and (ptruint(p)<ptruint(@ebss)) then
 
972
    goto _exit;
 
973
{$endif windows}
 
974
 
 
975
{$IFDEF OS2}
 
976
  { inside stack ? }
 
977
  if (PtrUInt (P) > PtrUInt (Get_Frame)) and
 
978
     (PtrUInt (P) < PtrUInt (StackTop)) then
 
979
    goto _exit;
 
980
  { inside data or bss ? }
 
981
  if (PtrUInt (P) >= PtrUInt (@etext)) and (PtrUInt (P) < PtrUInt (@eend)) then
 
982
    goto _exit;
 
983
{$ENDIF OS2}
 
984
 
 
985
{$ifdef linux}
 
986
  { inside stack ? }
 
987
  if (ptruint(p)>ptruint(get_frame)) and
 
988
     (ptruint(p)<$c0000000) then      //todo: 64bit!
 
989
    goto _exit;
 
990
  { inside data or bss ? }
 
991
  if (ptruint(p)>=ptruint(@etext)) and (ptruint(p)<ptruint(@eend)) then
 
992
    goto _exit;
 
993
{$endif linux}
 
994
 
 
995
{$ifdef morphos}
 
996
  { inside stack ? }
 
997
  stack_top:=ptruint(StackBottom)+StackLength;
 
998
  if (ptruint(p)<stack_top) and (ptruint(p)>ptruint(StackBottom)) then
 
999
    goto _exit;
 
1000
  { inside data or bss ? }
 
1001
  {$WARNING data and bss checking missing }
 
1002
{$endif morphos}
 
1003
 
 
1004
  {$ifdef darwin}
 
1005
  {$warning No checkpointer support yet for Darwin}
 
1006
  exit;
 
1007
  {$endif}
 
1008
 
 
1009
  { first try valid list faster }
 
1010
 
 
1011
{$ifdef EXTRA}
 
1012
  pp:=loc_info^.heap_valid_last;
 
1013
  while pp<>nil do
 
1014
   begin
 
1015
     { inside this valid block ! }
 
1016
     { we can be changing the extrainfo !! }
 
1017
     if (ptruint(p)>=ptruint(pp)+sizeof(theap_mem_info){+extra_info_size}) and
 
1018
        (ptruint(p)<=ptruint(pp)+sizeof(theap_mem_info)+extra_info_size+pp^.size) then
 
1019
       begin
 
1020
          { check allocated block }
 
1021
          if ((pp^.sig=$DEADBEEF) and not usecrc) or
 
1022
             ((pp^.sig=calculate_sig(pp)) and usecrc) or
 
1023
          { special case of the fill_extra_info call }
 
1024
             ((pp=loc_info^.heap_valid_last) and usecrc and (pp^.sig=$DEADBEEF)
 
1025
              and loc_info^.inside_trace_getmem) then
 
1026
            goto _exit
 
1027
          else
 
1028
            begin
 
1029
              writeln(ptext^,'corrupted heap_mem_info');
 
1030
              dump_error(pp,ptext^);
 
1031
              halt(1);
 
1032
            end;
 
1033
       end
 
1034
     else
 
1035
       pp:=pp^.prev_valid;
 
1036
     inc(i);
 
1037
     if i>loc_info^.getmem_cnt-loc_info^.freemem_cnt then
 
1038
      begin
 
1039
         writeln(ptext^,'error in linked list of heap_mem_info');
 
1040
         halt(1);
 
1041
      end;
 
1042
   end;
 
1043
  i:=0;
 
1044
{$endif EXTRA}
 
1045
  pp:=loc_info^.heap_mem_root;
 
1046
  while pp<>nil do
 
1047
   begin
 
1048
     { inside this block ! }
 
1049
     if (ptruint(p)>=ptruint(pp)+sizeof(theap_mem_info)+ptruint(extra_info_size)) and
 
1050
        (ptruint(p)<=ptruint(pp)+sizeof(theap_mem_info)+ptruint(extra_info_size)+ptruint(pp^.size)) then
 
1051
        { allocated block }
 
1052
       if ((pp^.sig=$DEADBEEF) and not usecrc) or
 
1053
          ((pp^.sig=calculate_sig(pp)) and usecrc) then
 
1054
          goto _exit
 
1055
       else
 
1056
         begin
 
1057
            writeln(ptext^,'pointer $',hexstr(p),' points into invalid memory block');
 
1058
            dump_error(pp,ptext^);
 
1059
            runerror(204);
 
1060
         end;
 
1061
     pp:=pp^.previous;
 
1062
     inc(i);
 
1063
     if i>loc_info^.getmem_cnt then
 
1064
      begin
 
1065
         writeln(ptext^,'error in linked list of heap_mem_info');
 
1066
         halt(1);
 
1067
      end;
 
1068
   end;
 
1069
  writeln(ptext^,'pointer $',hexstr(p),' does not point to valid memory block');
 
1070
  dump_error(p,ptext^);
 
1071
  runerror(204);
 
1072
_exit:
 
1073
end;
 
1074
 
 
1075
{*****************************************************************************
 
1076
                              Dump Heap
 
1077
*****************************************************************************}
 
1078
 
 
1079
procedure dumpheap;
 
1080
var
 
1081
  pp : pheap_mem_info;
 
1082
  i : ptrint;
 
1083
  ExpectedHeapFree : ptruint;
 
1084
  status : TFPCHeapStatus;
 
1085
  ptext : ^text;
 
1086
  loc_info: pheap_info;
 
1087
begin
 
1088
  loc_info:=@heap_info;
 
1089
  if useownfile then
 
1090
    ptext:=@ownfile
 
1091
  else
 
1092
    ptext:=@stderr;
 
1093
  pp:=loc_info^.heap_mem_root;
 
1094
  Writeln(ptext^,'Heap dump by heaptrc unit');
 
1095
  Writeln(ptext^,loc_info^.getmem_cnt, ' memory blocks allocated : ',
 
1096
    loc_info^.getmem_size,'/',loc_info^.getmem8_size);
 
1097
  Writeln(ptext^,loc_info^.freemem_cnt,' memory blocks freed     : ',
 
1098
    loc_info^.freemem_size,'/',loc_info^.freemem8_size);
 
1099
  Writeln(ptext^,loc_info^.getmem_cnt-loc_info^.freemem_cnt,
 
1100
    ' unfreed memory blocks : ',loc_info^.getmem_size-loc_info^.freemem_size);
 
1101
  status:=SysGetFPCHeapStatus;
 
1102
  Write(ptext^,'True heap size : ',status.CurrHeapSize);
 
1103
  if EntryMemUsed > 0 then
 
1104
    Writeln(ptext^,' (',EntryMemUsed,' used in System startup)')
 
1105
  else
 
1106
    Writeln(ptext^);
 
1107
  Writeln(ptext^,'True free heap : ',status.CurrHeapFree);
 
1108
  ExpectedHeapFree:=status.CurrHeapSize
 
1109
    -(loc_info^.getmem8_size-loc_info^.freemem8_size)
 
1110
    -(loc_info^.getmem_cnt-loc_info^.freemem_cnt)*(sizeof(theap_mem_info)+extra_info_size)
 
1111
    -EntryMemUsed;
 
1112
  If ExpectedHeapFree<>status.CurrHeapFree then
 
1113
    Writeln(ptext^,'Should be : ',ExpectedHeapFree);
 
1114
  i:=loc_info^.getmem_cnt-loc_info^.freemem_cnt;
 
1115
  while pp<>nil do
 
1116
   begin
 
1117
     if i<0 then
 
1118
       begin
 
1119
          Writeln(ptext^,'Error in heap memory list');
 
1120
          Writeln(ptext^,'More memory blocks than expected');
 
1121
          exit;
 
1122
       end;
 
1123
     if ((pp^.sig=$DEADBEEF) and not usecrc) or
 
1124
        ((pp^.sig=calculate_sig(pp)) and usecrc) then
 
1125
       begin
 
1126
          { this one was not released !! }
 
1127
          if exitcode<>203 then
 
1128
            call_stack(pp,ptext^);
 
1129
          dec(i);
 
1130
       end
 
1131
     else if pp^.sig<>$AAAAAAAA then
 
1132
       begin
 
1133
          dump_error(pp,ptext^);
 
1134
{$ifdef EXTRA}
 
1135
          dump_error(pp,error_file);
 
1136
{$endif EXTRA}
 
1137
          loc_info^.error_in_heap:=true;
 
1138
       end
 
1139
{$ifdef EXTRA}
 
1140
     else if pp^.release_sig<>calculate_release_sig(pp) then
 
1141
       begin
 
1142
          dump_change_after(pp,ptext^);
 
1143
          dump_change_after(pp,error_file);
 
1144
          loc_info^.error_in_heap:=true;
 
1145
       end
 
1146
{$endif EXTRA}
 
1147
       ;
 
1148
     pp:=pp^.previous;
 
1149
   end;
 
1150
  if HaltOnNotReleased and (loc_info^.getmem_cnt<>loc_info^.freemem_cnt) then
 
1151
    exitcode:=203;
 
1152
end;
 
1153
 
 
1154
 
 
1155
{*****************************************************************************
 
1156
                                AllocMem
 
1157
*****************************************************************************}
 
1158
 
 
1159
function TraceAllocMem(size:ptruint):Pointer;
 
1160
begin
 
1161
  TraceAllocMem:=SysAllocMem(size);
 
1162
end;
 
1163
 
 
1164
 
 
1165
{*****************************************************************************
 
1166
                            No specific tracing calls
 
1167
*****************************************************************************}
 
1168
 
 
1169
procedure TraceInitThread;
 
1170
var
 
1171
  loc_info: pheap_info;
 
1172
begin
 
1173
  loc_info := @heap_info;
 
1174
{$ifdef EXTRA}
 
1175
  loc_info^.heap_valid_first := nil;
 
1176
  loc_info^.heap_valid_last := nil;
 
1177
{$endif}
 
1178
  loc_info^.heap_mem_root := nil;
 
1179
  loc_info^.getmem_cnt := 0;
 
1180
  loc_info^.freemem_cnt := 0;
 
1181
  loc_info^.getmem_size := 0;
 
1182
  loc_info^.freemem_size := 0;
 
1183
  loc_info^.getmem8_size := 0;
 
1184
  loc_info^.freemem8_size := 0;
 
1185
  loc_info^.error_in_heap := false;
 
1186
  loc_info^.inside_trace_getmem := false;
 
1187
  EntryMemUsed := SysGetFPCHeapStatus.CurrHeapUsed;
 
1188
end;
 
1189
 
 
1190
procedure TraceRelocateHeap;
 
1191
begin
 
1192
  main_relo_todolist := @heap_info.heap_free_todo;
 
1193
  initcriticalsection(todo_lock);
 
1194
end;
 
1195
 
 
1196
procedure move_heap_info(src_info, dst_info: pheap_info);
 
1197
var
 
1198
  heap_mem: pheap_mem_info;
 
1199
begin
 
1200
  if src_info^.heap_free_todo <> nil then
 
1201
    finish_heap_free_todo_list(src_info);
 
1202
  if dst_info^.heap_free_todo <> nil then
 
1203
    finish_heap_free_todo_list(dst_info);
 
1204
  heap_mem := src_info^.heap_mem_root;
 
1205
  if heap_mem <> nil then
 
1206
  begin
 
1207
    repeat
 
1208
      heap_mem^.todolist := @dst_info^.heap_free_todo;
 
1209
      if heap_mem^.previous = nil then break;
 
1210
      heap_mem := heap_mem^.previous;
 
1211
    until false;
 
1212
    heap_mem^.previous := dst_info^.heap_mem_root;
 
1213
    if dst_info^.heap_mem_root <> nil then
 
1214
      dst_info^.heap_mem_root^.next := heap_mem;
 
1215
    dst_info^.heap_mem_root := src_info^.heap_mem_root;
 
1216
  end;
 
1217
  inc(dst_info^.getmem_cnt, src_info^.getmem_cnt);
 
1218
  inc(dst_info^.getmem_size, src_info^.getmem_size);
 
1219
  inc(dst_info^.getmem8_size, src_info^.getmem8_size);
 
1220
  inc(dst_info^.freemem_cnt, src_info^.freemem_cnt);
 
1221
  inc(dst_info^.freemem_size, src_info^.freemem_size);
 
1222
  inc(dst_info^.freemem8_size, src_info^.freemem8_size);
 
1223
  dst_info^.error_in_heap := dst_info^.error_in_heap or src_info^.error_in_heap;
 
1224
{$ifdef EXTRA}
 
1225
  if assigned(dst_info^.heap_valid_first) then
 
1226
    dst_info^.heap_valid_first^.prev_valid := src_info^.heap_valid_last
 
1227
  else
 
1228
    dst_info^.heap_valid_last := src_info^.heap_valid_last;
 
1229
  dst_info^.heap_valid_first := src_info^.heap_valid_first;
 
1230
{$endif}
 
1231
end;
 
1232
 
 
1233
procedure TraceExitThread;
 
1234
var
 
1235
  loc_info: pheap_info;
 
1236
begin
 
1237
  loc_info := @heap_info;
 
1238
  entercriticalsection(todo_lock);
 
1239
  move_heap_info(loc_info, @orphaned_info);
 
1240
  leavecriticalsection(todo_lock);
 
1241
end;
 
1242
 
 
1243
function TraceGetHeapStatus:THeapStatus;
 
1244
begin
 
1245
  TraceGetHeapStatus:=SysGetHeapStatus;
 
1246
end;
 
1247
 
 
1248
function TraceGetFPCHeapStatus:TFPCHeapStatus;
 
1249
begin
 
1250
    TraceGetFPCHeapStatus:=SysGetFPCHeapStatus;
 
1251
end;
 
1252
 
 
1253
 
 
1254
{*****************************************************************************
 
1255
                             Program Hooks
 
1256
*****************************************************************************}
 
1257
 
 
1258
Procedure SetHeapTraceOutput(const name : string);
 
1259
var i : ptruint;
 
1260
begin
 
1261
   if useownfile then
 
1262
     begin
 
1263
       useownfile:=false;
 
1264
       close(ownfile);
 
1265
     end;
 
1266
   assign(ownfile,name);
 
1267
{$I-}
 
1268
   append(ownfile);
 
1269
   if IOResult<>0 then
 
1270
     Rewrite(ownfile);
 
1271
{$I+}
 
1272
   useownfile:=true;
 
1273
   for i:=0 to Paramcount do
 
1274
     write(ownfile,ParamStr(i),' ');
 
1275
   writeln(ownfile);
 
1276
end;
 
1277
 
 
1278
procedure SetHeapExtraInfo( size : ptruint;fillproc : tfillextrainfoproc;displayproc : tdisplayextrainfoproc);
 
1279
begin
 
1280
  { the total size must stay multiple of 8, also allocate 2 pointers for
 
1281
    the fill and display procvars }
 
1282
  exact_info_size:=size + sizeof(theap_extra_info);
 
1283
  extra_info_size:=(exact_info_size+7) and not 7;
 
1284
  fill_extra_info_proc:=fillproc;
 
1285
  display_extra_info_proc:=displayproc;
 
1286
end;
 
1287
 
 
1288
 
 
1289
{*****************************************************************************
 
1290
                           Install MemoryManager
 
1291
*****************************************************************************}
 
1292
 
 
1293
const
 
1294
  TraceManager:TMemoryManager=(
 
1295
    NeedLock : true;
 
1296
    Getmem  : @TraceGetMem;
 
1297
    Freemem : @TraceFreeMem;
 
1298
    FreememSize : @TraceFreeMemSize;
 
1299
    AllocMem : @TraceAllocMem;
 
1300
    ReAllocMem : @TraceReAllocMem;
 
1301
    MemSize : @TraceMemSize;
 
1302
    InitThread: @TraceInitThread;
 
1303
    DoneThread: @TraceExitThread;
 
1304
    RelocateHeap: @TraceRelocateHeap;
 
1305
    GetHeapStatus : @TraceGetHeapStatus;
 
1306
    GetFPCHeapStatus : @TraceGetFPCHeapStatus;
 
1307
  );
 
1308
 
 
1309
procedure TraceInit;
 
1310
begin
 
1311
  MakeCRC32Tbl;
 
1312
  main_orig_todolist := @heap_info.heap_free_todo;
 
1313
  main_relo_todolist := nil;
 
1314
  TraceInitThread;
 
1315
  SetMemoryManager(TraceManager);
 
1316
  useownfile:=false;
 
1317
  if outputstr <> '' then
 
1318
     SetHeapTraceOutput(outputstr);
 
1319
{$ifdef EXTRA}
 
1320
  Assign(error_file,'heap.err');
 
1321
  Rewrite(error_file);
 
1322
{$endif EXTRA}
 
1323
end;
 
1324
 
 
1325
procedure TraceExit;
 
1326
begin
 
1327
  { no dump if error
 
1328
    because this gives long long listings }
 
1329
  { clear inoutres, in case the program that quit didn't }
 
1330
  ioresult;
 
1331
  if (exitcode<>0) and (erroraddr<>nil) then
 
1332
    begin
 
1333
       if useownfile then
 
1334
         begin
 
1335
           Writeln(ownfile,'No heap dump by heaptrc unit');
 
1336
           Writeln(ownfile,'Exitcode = ',exitcode);
 
1337
         end
 
1338
       else
 
1339
         begin
 
1340
           Writeln(stderr,'No heap dump by heaptrc unit');
 
1341
           Writeln(stderr,'Exitcode = ',exitcode);
 
1342
         end;
 
1343
       if useownfile then
 
1344
         begin
 
1345
           useownfile:=false;
 
1346
           close(ownfile);
 
1347
         end;
 
1348
       exit;
 
1349
    end;
 
1350
  move_heap_info(@orphaned_info, @heap_info);
 
1351
  dumpheap;
 
1352
  if heap_info.error_in_heap and (exitcode=0) then
 
1353
    exitcode:=203;
 
1354
  if main_relo_todolist <> nil then
 
1355
    donecriticalsection(todo_lock);
 
1356
{$ifdef EXTRA}
 
1357
  Close(error_file);
 
1358
{$endif EXTRA}
 
1359
   if useownfile then
 
1360
     begin
 
1361
       useownfile:=false;
 
1362
       close(ownfile);
 
1363
     end;
 
1364
end;
 
1365
 
 
1366
{$if defined(win32) or defined(win64)}
 
1367
   function GetEnvironmentStrings : pchar; stdcall;
 
1368
     external 'kernel32' name 'GetEnvironmentStringsA';
 
1369
   function FreeEnvironmentStrings(p : pchar) : longbool; stdcall;
 
1370
     external 'kernel32' name 'FreeEnvironmentStringsA';
 
1371
Function  GetEnv(envvar: string): string;
 
1372
var
 
1373
   s : string;
 
1374
   i : ptruint;
 
1375
   hp,p : pchar;
 
1376
begin
 
1377
   getenv:='';
 
1378
   p:=GetEnvironmentStrings;
 
1379
   hp:=p;
 
1380
   while hp^<>#0 do
 
1381
     begin
 
1382
        s:=strpas(hp);
 
1383
        i:=pos('=',s);
 
1384
        if upcase(copy(s,1,i-1))=upcase(envvar) then
 
1385
          begin
 
1386
             getenv:=copy(s,i+1,length(s)-i);
 
1387
             break;
 
1388
          end;
 
1389
        { next string entry}
 
1390
        hp:=hp+strlen(hp)+1;
 
1391
     end;
 
1392
   FreeEnvironmentStrings(p);
 
1393
end;
 
1394
{$else defined(win32) or defined(win64)}
 
1395
 
 
1396
{$ifdef wince}
 
1397
Function GetEnv(P:string):Pchar;
 
1398
begin
 
1399
  { WinCE does not have environment strings.
 
1400
    Add some way to specify heaptrc options? }
 
1401
  GetEnv:=nil;
 
1402
end;
 
1403
{$else wince}
 
1404
 
 
1405
Function GetEnv(P:string):Pchar;
 
1406
{
 
1407
  Searches the environment for a string with name p and
 
1408
  returns a pchar to it's value.
 
1409
  A pchar is used to accomodate for strings of length > 255
 
1410
}
 
1411
var
 
1412
  ep    : ppchar;
 
1413
  i     : ptruint;
 
1414
  found : boolean;
 
1415
Begin
 
1416
  p:=p+'=';            {Else HOST will also find HOSTNAME, etc}
 
1417
  ep:=envp;
 
1418
  found:=false;
 
1419
  if ep<>nil then
 
1420
   begin
 
1421
     while (not found) and (ep^<>nil) do
 
1422
      begin
 
1423
        found:=true;
 
1424
        for i:=1 to length(p) do
 
1425
         if p[i]<>ep^[i-1] then
 
1426
          begin
 
1427
            found:=false;
 
1428
            break;
 
1429
          end;
 
1430
        if not found then
 
1431
         inc(ep);
 
1432
      end;
 
1433
   end;
 
1434
  if found then
 
1435
   getenv:=ep^+length(p)
 
1436
  else
 
1437
   getenv:=nil;
 
1438
end;
 
1439
{$endif wince}
 
1440
{$endif win32}
 
1441
 
 
1442
procedure LoadEnvironment;
 
1443
var
 
1444
  i,j : ptruint;
 
1445
  s   : string;
 
1446
begin
 
1447
  s:=Getenv('HEAPTRC');
 
1448
  if pos('keepreleased',s)>0 then
 
1449
   keepreleased:=true;
 
1450
  if pos('disabled',s)>0 then
 
1451
   useheaptrace:=false;
 
1452
  if pos('nohalt',s)>0 then
 
1453
   haltonerror:=false;
 
1454
  if pos('haltonnotreleased',s)>0 then
 
1455
   HaltOnNotReleased :=true;
 
1456
  i:=pos('log=',s);
 
1457
  if i>0 then
 
1458
   begin
 
1459
     outputstr:=copy(s,i+4,255);
 
1460
     j:=pos(' ',outputstr);
 
1461
     if j=0 then
 
1462
      j:=length(outputstr)+1;
 
1463
     delete(outputstr,j,255);
 
1464
   end;
 
1465
end;
 
1466
 
 
1467
// additions for codetools
 
1468
{$DEFINE MC_ImplementationEnd}
 
1469
{$i memcheck_laz.inc}
 
1470
{$UNDEF MC_ImplementationEnd}
 
1471
 
 
1472
Initialization
 
1473
  LoadEnvironment;
 
1474
  { heaptrc can be disabled from the environment }
 
1475
  if useheaptrace then
 
1476
   TraceInit;
 
1477
  CheckHeapWrtMemCnt('memcheck.pas Initialization');
 
1478
finalization
 
1479
  if useheaptrace then
 
1480
   TraceExit;
 
1481
end.
 
1482