-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathMemCheck.pas
5367 lines (4849 loc) · 163 KB
/
MemCheck.pas
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
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
//===========================================================================//
// Autor: Jean Marc Eber & Vincent Mahon, Société Générale, INFI/SGOP/R&D
// Module: MemCheck
// Description: The ultimate memory troubles hunter.
//===========================================================================//
(* ------------------------------------------------------------------------------
2009-05-27: "Vadim V.Lopushansky" <[email protected]>, Kyiv, Ukraine.
Added some features:
- added support RAD Studio 2009, 2010
- fixed: AV: CallerOfReallocMem when compiled with optimization $O+
- fixed: AV: LeakTrackingGetMem, LeakTrackingFreeMem.
- fixed: At processing a log the flags BlocksToShow and "at absence of memory leaks" are taken into account
- fixed: Transition to a line of a code where occurs outflow of memory is made with check of work of the
program from under a debugger ( look: IsDebugged ).
- fixed: look UnMemChk: AV after call OldMemoryManager.FreeMem(LastBlock) when LastBlock<>nil and MemCheckActive=True
look Unit_FInit: forced restore of "old memory manager"
- checked/tested calculation of the addresses on Delphi 5 ... RAD Studio 2010
- reimplementation: InitializeOnce
- changed procedute ChangeFinalizationsOrder to function
- added DoFinalizeOnce for destroying unit allocated resources
- added class filter (look MemCheckIgnoredClassAdd and IgnoreTrace flag in TMemoryBlockHeader)
- added use external jcl dll "JclDbgMapOfAddr.dll" (look USE_JEDI_DLL). Is recommended for usage as default option.
- added autodetect DELPHI_70_MODE or DELPHI_71_MODE (look: _compiler_delphi_71)
- added: Fast and stable quit from application (exe only)
- remove: Math unit
- alternative implementation finalization units (look: HOOK_ALT, NewFinalizeUnits)
- added: additional dynamic initialization MemCheck by startup parameters (look: MemCheckInitByParamStr).
examples:
>run <app_name.exe> [/MemCheck_Parameter]
MemCheck_Parameter:
MemCheck100 or /MemCheck - leak chek for objects only
MemCheck010 - leak chek for GetMem only
MemCheck001 - leak chek for GetMem and ReallocMem only
MemCheck111 - leak chek full
MemCheck=000 - ignore all
MemCheck=010 - leak chek for GetMem only
MemCheck=001 - leak chek for GetMem and ReallocMem only
MemCheck=111 - leak chek full
- added demo application (pMemCheck.dpr; pMemCheck.res; IOTextDevices.pas; uMemCheck.pas; uMemCheck.dfm)
TODO: !!! **** **** **** **** **** **** **** **** **** **** **** **** **** **** **** **** **** **** **** *****
- look: ALT_TRACKING_REALLOKMEM
- $DENYPACKAGEUNIT
need test with usage from package
TODO: !!! **** **** **** **** **** **** **** **** **** **** **** **** **** **** **** **** **** **** **** *****
- AV finalization
FastMM compatible -> MemCheck module for itself must use separate memory manager (? VirtualAlAlloc)
FastMM on finalization is set system or bad mem manager.
But memcheck is allocated memory by FasMM -> AV
TODO: !!! **** **** **** **** **** **** **** **** **** **** **** **** **** **** **** **** **** **** **** *****
- CallerIsNewInstance not work when usage FastObj.pas
**** **** **** **** **** **** **** **** **** **** **** **** **** **** **** **** **** **** **** **** **** ****
--------------------------------------------------------------------------------*)
(*
MemCheck: the ultimate memory troubles hunter
Created by: Jean Marc Eber & Vincent Mahon, Société Générale, INFI/SGOP/R&D
Version 2.76.1 -> Also update OutputFileHeader when changing the version #
Revision 06.08.2008
Contact...
--
http://v.mahon.free.fr/pro/freeware/memcheck
--
https://launchpad.net/memcheck
http://bazaar.launchpad.net/~denisgolovan/memcheck/main/files/2
Denis Golovan at [email protected] or [email protected]
--
http://code.google.com/p/delphi-memcheck/
http://code.google.com/p/delphi-memcheck/downloads/list
"Vadim V.Lopushansky" <[email protected]>
--
Version 2.77 (Delphi 5 ... RAD Studio 2010)
--
Mail address:
Tour Société Générale
Sgib/Sgop/R&D
92987 Paris - La Défense cedex
France
Copyrights...
The authors grant you the right to modify/change the source code as long as the original authors are mentionned.
Please let us know if you make any improvements, so that we can keep an up to date version. We also welcome
all comments, preferably by email.
Portions of this file (all the code dealing with TD32 debug information) where derived from the following work, with permission.
Reuse of this code in a commercial application is not permitted. The portions are identified by a copyright notice.
> DumpFB.C Borland 32-bit Turbo Debugger dumper (FB09 & FB0A)
> Clive Turvey, Electronics Engineer, July 1998
> Copyright (C) Tenth Planet Software Intl., Clive Turvey 1998. All rights reserved.
> Clive Turvey <[email protected]> http://www.tbcnet.com/~clive/vcomwinp.html
Disclaimer...
You use MemCheck at your own risks. This means that you cannot hold the authors or Société Générale to be
responsible for any software\hardware problems you may encounter while using this module.
General information...
MemCheck replaces Delphi's memory manager with a home made one. This one logs information each time memory is
allocated, reallocated or freed. When the program ends, information about memory problems is provided in a log file
and exceptions are raised at problematic points.
Basic use...
Set the MemCheckLogFileName option. Call MemChk when you want to start the memory monitoring. Nothing else to do !
When your program terminates and the finalization is executed, MemCheck will report the problems. This is the
behaviour you'll obtain if you change no option in MemCheck.
Features...
- List of memory spaces not deallocated, and raising of EMemoryLeak exception at the exact place in the source code
- Call stack at allocation time. User chooses to see or not to see this call stack at run time (using ShowCallStack),
when a EMemoryLeak is raised.
- Tracking of virtual method calls after object's destruction (we change the VMT of objects when they are destroyed)
- Tracking of method calls on an interface while the object attached to the interface has been destroyed
- Checking of writes beyond end of allocated blocks (we put a marker at the end of a block on allocation)
- Fill freed block with a byte (this allows for example to set fields of classes to Nil, or buffers to $FF, or whatever)
- Detect writes in deallocated blocks (we do this by not really deallocating block, and checking them on end - this
can be time consuming)
- Statistics collection about objects allocation (how many objects of a given class are created ?)
- Time stamps can be indicated and will appear in the output
Options and parameters...
- You can specify the log files names (MemCheckLogFileName)
- It is possible to tell MemCheck that you are instanciating an object in a special way - See doc for
CheckForceAllocatedType
- Clients can specify the depth of the call stack they want to store (StoredCallStackDepth)
Warnings...
- MemCheck is based on a lot of low-level hacks. Some parts of it will not work on other versions of Delphi
without being revisited (as soon as System has been recompiled, MemCheck is very likely to behave strangely,
because for example the address of InitContext will be bad).
- Some debugging tools exploit the map file to return source location information. We chose not to do that, because
we think the way MemCheck raises exceptions at the good places is better. It is still possible to use "find error"
in Delphi.
- Memcheck is not able to report accurate call stack information about a leak of a class which does not redefine
its constructor. For example, if an instance of TStringList is never deallocated, the call stack MemCheck will
report is not very complete. However, the leak is correctly reported by MemCheck.
A word about uses...
Since leaks are reported on end of execution (finalization of this unit), we need as many finalizations to occur
before memcheck's, so that if some memory is freed in these finalizations, it is not erroneously reported as leak. In order to
finalize MemCheck as late as possible, we use a trick to change the order of the list of finalizations.
Other memory managing products which are available (found easily on the internet) do not have this
problem because they just rely on putting the unit first in the DPR; but this is not safe without a build all.
In MemCheck we absolutely need to use two units: SysUtils and Windows.
Then, I decided in MemCheck 2.54 to use the unit Classes because I think it will lead to much simpler code.
We also use two units which we can use without risk since they dont have a finalization: SyncObjs.
An analysis of the uses clauses of these five units shows that in fact MemCheck uses indirectly the following units:
Classes, Typinfo, Consts, Variants, VaRUtils, SysUtils, ActiveX, Messages, SysConst, Windows, SyncObjs, System, SysInit and Types.
Of these, only Classes, Variants, System and SysUtils have a finalization section. I checked and it is not possible to have a leak
reported by MemCheck which is not correct because the memory would have been freed by one of these finalizations.
In the procedure ChangeFinalizationsOrder I make sure that only these four units are finalized after MemCheck (I could have decided for
the fifteen, but this would be more work, and I know it is useless).
*)
unit MemCheck;
// ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ----
//
// compiler options:
//
{$A+,H+,B-,J+,R-}
{.$ALIGN ON}
{.$ALIGN 8}
{.$MINENUMSIZE 4}
{$MINENUMSIZE 1}
{$DENYPACKAGEUNIT} // todo: test
//disable debug info generation for this unit
//this way integrated debugger does not enter memcheck every time allocation happens
{$D-,L-}
{$IFDEF _MEMCHECK_DEBUG_}
{$D+,L+,O-,R+} // developer debuging
{$DEFINE DEBUG}
{$ENDIF}
//test options
{.$O+}
{.$D+,L+,O-,R+}
//test.
// ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ----
//
// Hook options:
//
{$UNDEF HOOK_ALT}
{$DEFINE HOOK_ALT} { Optional: alternative implementation finalization units. Is recommended for usage. }
// ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ----
//
// "JEDI CODE LIBRARY" (JCL) options:
//
{$UNDEF USE_JEDI}
{$UNDEF USE_JEDI_JCL}
{$UNDEF USE_JEDI_DLL}
{$DEFINE USE_JEDI} { Optional } // Is recommended for usage. Need external "JclDbgMapOfAddr.dll".
{$IFDEF USE_JEDI}
// Usage "JEDI CODE LIBRARY" (JCL) for reading map file information.
// Need compile project with linker option "map file detailed information".
// And not need linker option "Include TD32 debug info".
{$DEFINE USE_JEDI_DLL} // { Optional } // Is recommended for usage. Need external "JclDbgMapOfAddr.dll".
{$IFNDEF USE_JEDI_DLL}
{$DEFINE USE_JEDI_JCL} // Only fo old JCL version (1.96). Not recommended for usage.
{$ENDIF}
{$ENDIF}
// ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ----
//
// VCL options:
//
{$UNDEF USE_VCL}
{$IFNDEF HOOK_ALT}
{$IFDEF BDS}
{$DEFINE USE_VCL} { Optional }
{$IFDEF HOOK_ALT}
{$UNDEF USE_VCL} { Optional }
{$ENDIF}
{$ENDIF}
{$ENDIF}
// ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ----
{$UNDEF D3_UP} // Delphi 3
{$UNDEF D4_UP} // Delphi 4
{$UNDEF D5_UP} // Delphi 5
{$UNDEF D6_UP} // Delphi 6
{$UNDEF D7_UP} // Delphi 7
{$UNDEF D8_UP} // Delphi 8
{$UNDEF D9_UP} // BDS 2005
{$UNDEF D10_UP} // BDS 2006
{$UNDEF D11_UP} // RAD Studio 2007
{$UNDEF D12_UP} // RAD Studio 2009
{$UNDEF D13_UP} // RAD Studio 2010
{$UNDEF D14_UP} // RAD Studio 2011
{$UNDEF BDS}
{$UNDEF _INLINE_}
{$UNDEF _UNICODE_}
// ---
{$IFNDEF LINUX}
{$IFNDEF CLR}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$ENDIF}
// ---
{$IFNDEF VER80}
{$IFNDEF VER90}
{$IFNDEF VER93}
{$DEFINE D3_UP} { Delphi 3.0 or higher }
{$IFNDEF VER110}
{$DEFINE D4_UP} { Delphi 4.0 or higher }
{$IFNDEF VER120}
{$DEFINE D5_UP}
{$IFNDEF VER130}
{$DEFINE D6_UP} { Delphi 6.0 or higher }
{$IFNDEF VER140}
{$DEFINE D7_UP} { Delphi 7.0 or higher }
{$IFNDEF VER150}
{$DEFINE D9_UP} { BDS 2005 (9) or higher }
{$IFNDEF VER170}
{$DEFINE D10_UP} { BDS 2006 (10) or higher }
{$IFDEF VER185}
{$DEFINE D11_UP} { RAD Studio 2007 (11) or higher }
{$ELSE}
{$IFNDEF VER180}
{$DEFINE D12_UP} { RAD Studio 2009 (12) or higher }
{$IFNDEF VER200}
{$DEFINE D13_UP} { RAD Studio 2010 (13) or higher }
{$IFNDEF VER210}
{$DEFINE D14_UP} { RAD Studio 2010 (13) or higher }
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
// ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ----
{$IFNDEF D5_UP}
ERROR: UNSUPPORTED COMPILER VERSION
{$ENDIF}
{$IFDEF D14_UP}
{$MESSAGE FATAL 'UNSUPPORTED COMPILER VERSION!'}
ERROR: UNSUPPORTED COMPILER VERSION
{$ENDIF}
// ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ----
{$IFDEF D9_UP}
{$DEFINE BDS}
{$ENDIF}
// ---
{$IFDEF D9_UP}
{$DEFINE _INLINE_} { Optional }
{$ENDIF}
// ---
{$IFDEF D12_UP}
{$IFDEF UNICODE}
{$DEFINE _UNICODE_}
{$ENDIF}
{$ENDIF}
// ---
{$UNDEF D7_ONLY}
{$IFNDEF BDS}{$IFDEF D7_UP}
{$DEFINE D7_ONLY}
{$ENDIF}{$ENDIF}
// ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ----
{$IFDEF D6_UP}
{$WARN SYMBOL_PLATFORM OFF} // Suppress .Net warnings
{$WARN SYMBOL_DEPRECATED OFF}
{$WARN UNIT_PLATFORM OFF} // NOT certified for Kylix
{$WARN UNIT_DEPRECATED OFF} // NOT certified for Kylix
{$WRITEABLECONST ON}
{$ENDIF}
// ---
{$IFDEF D7_UP}
{$WARN UNSAFE_CAST OFF} // Suppress .Net warnings
{$WARN UNSAFE_TYPE OFF} // Suppress .Net warnings
{$WARN UNSAFE_CODE OFF} // Suppress .Net warnings
{$ENDIF}
// ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ----
{$IFDEF D12_UP}
{$IFDEF _UNICODE_}
{$IFDEF USE_JEDI_JCL} // not supported old version jedi
{$UNDEF USE_JEDI_JCL}
{$DEFINE USE_JEDI_DLL}
{$ENDIF}
{$ENDIF}
{$ENDIF}
// ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ----
interface
const
{***************************************************}
{***} MemCheckVersion = '2.77.0 [2009-05-28]'; {***}
{***************************************************}
procedure MemChk;
{Activates MemCheck and resets the allocated blocks stack.
Warning: the old stack is lost ! - It is the client's duty to commit the
releasable blocks by calling CommitReleases(AllocatedBlocks)}
procedure UnMemChk;
{sets back the memory manager that was installed before MemChk was called
If MemCheck is not active, this does not matter. The default delphi memory manager is set.
You should be very careful about calling this routine and know exactly what it does (see the FAQ on the web site)}
procedure CommitReleases;
{really releases the blocks}
procedure AddTimeStampInformation(const i: string);
{Logs the given information as associated with the current time stamp
Requires that MemCheck is active}
procedure LogSevereExceptions(const WithVersionInfo: string);
{Activates the exception logger}
function MemoryBlockCorrupted(p: Pointer): Boolean;
{Is the given block bad ?
P is a block you may for example have created with GetMem, or P can be an object.
Bad means you have written beyond the block's allocated space or the memory for this object was freed.
If P was allocated before MemCheck was launched, we return False}
function BlockAllocationAddress(p: Pointer): Pointer;
{The address at which P was allocated
If MemCheck was not running when P was allocated (ie we do not find our magic number), we return $00000000}
function IsMemCheckActive: Boolean;
{Is MemCheck currently running ?
ie, is the current memory manager memcheck's ?}
function TextualDebugInfoForAddress(const TheAddress: Cardinal): string; {$ifdef _inline_}inline;{$endif}
function TextualDebugInfoForAddressEx(const TheAddress: Cardinal; var bIsDebugInfo: Boolean): string;
var
MemCheckLogFileName: string = 'log.txt'; //The file memcheck will log information to
DeallocateFreedMemoryWhenBlockBiggerThan: Integer = 0;
{should blocks be really deallocated when FreeMem is called ? If you want all blocks to be deallocated, set this
constant to 0. If you want blocks to be never deallocated, set the cstte to MaxInt. When blocks are not deallocated,
MemCheck can give information about when the second deallocation occured}
ShowLogFileWhenUseful: Boolean = True;
const
StoredCallStackDepth = 26; // TMemoryBlockHeader: (StoredCallStackDepth + 1) * 4 mod 8 = 4
// StoredCallStackDepth: 2 ... 26, 28, 30, 32, 34, 36, 38 ... 52 ... 64 ... 96 ... 128 ...
{Size of the call stack we store when GetMem is called, must be an EVEN number}
{+}
AllowNotepadErrorInfo = False; // allow show errors log file in Notepad
SkipNullDebugInfo = {$IFNDEF USE_JEDI}False{$ELSE}False{$ENDIF}; { Optional }
MemCheckShowFinalizationInfo = {$IFNDEF _MEMCHECK_DEBUG_}{$IFDEF DEBUG}True{$ELSE}False{$ENDIF}{$ELSE}True{$ENDIF}; { Optional }
ReallocMemRestoreLeakTransaction = True;
MemCheckInitByParamStr = True; // define filter (BlocksToShow)
{ Examples:
>run <app_name.exe> [/MemCheck_Parameter]
MemCheck_Parameter:
MemCheck=000 - ignore all
MemCheck=100 - leak chek for Object only
MemCheck=010 - leak chek for GetMem only
MemCheck=001 - leak chek for GetMem and ReallocMem only
MemCheck=111 - leak chek full
or
MemCheck - leak chek full
MemCheck111 - leak chek full
MemCheck100 - leak chek for Object only
MemCheck010 - leak chek for GetMem only
MemCheck001 - leak chek for GetMem and ReallocMem only
}
{+.}
type
TCallStack = array[0..StoredCallStackDepth] of Pointer;
procedure FillCallStack(var St: TCallStack; const NbLevelsToExclude: Integer);
//Fills St with the call stack
function CallStackTextualRepresentation(const S: TCallStack; const LineHeader: string): string;
//Will contain CR/LFs
{+}
procedure MemCheckIgnoredClassAdd(AClassInfo: TClass);
procedure MemCheckIgnoredClassRemove(AClassInfo: TClass);
function MemCheckIsIgnoredClass(AClassInfo: TClass): Boolean;
function MemCheckInit(const sLevels: string): Boolean;
function MemCheckInitByFilter(ClassFilter, UserFilter, ReallocedUserFilter: Boolean): Boolean;
function MemCheckNewTransaction: Integer;
function MemCheckGetTransactionLeaks(LeakTransaction: Cardinal; const OutputFile: Text;
bRaiseLeakFirstAddress, bRaiseLeakAllAddresses, bCheckWipedBlocks, bHideLeaks: Boolean): Boolean; overload;
function IsDebugged: Boolean;
procedure OutputDebugString(const S: string); {$ifdef _inline_}inline;{$endif}
{+.}
implementation
uses
Windows, {Windows has no finalization, so is OK to use with no care}
Classes,
SyncObjs,
{$IFDEF USE_JEDI_JCL}JclDebug, {$ENDIF}
{$IFDEF D6_UP}Variants, {$ENDIF}
{$IFDEF USE_VCL}
{$IFDEF D6_UP}
Forms,
{$ENDIF}
{$ENDIF USE_VCL}
SysUtils; {Because of this uses, SysUtils must be finalized after MemCheck - Which is necessary anyway because SysUtils calls DoneExceptions in its finalization}
type
TKindOfMemory = (MClass, MUser, MReallocedUser);
TBlocksToShow = array[TKindOfMemory] of Boolean;
{MClass means the block carries an object
MUser means the block is a buffer of unknown type (in fact we just know this is not an object)
MReallocedUser means this block was reallocated}
const
NoDebugInfo = '(?)'; //'(no debug info)';
MemCheckLogFileNameSuffix = '_MemCheck.log';
(**************** MEMCHECK OPTIONS ********************)
DanglingInterfacesVerified = False;
{When an object is destroyed, should we fill the interface VMT with a special value which
will allow tracking of calls to this interface after the object was destroyed - This incompatible with CheckWipedBlocksOnTermination, so you have to choose}
WipeOutMemoryOnFreeMem = True;
{This is about what is done on memory freeing:
- for objects, this option replaces the VMT with a special one which will raise exceptions if a virtual method is called
- for other memory kinds, this will fill the memory space with the char below}
CharToUseToWipeOut: Char = #0;
//I choose #0 because this makes objet fields Nil, which is easier to debug. Tell me if you have a better idea !
CheckWipedBlocksOnTermination = True and WipeOutMemoryOnFreeMem and not (DanglingInterfacesVerified);
{When iterating on the blocks (in OutputAllocatedBlocks), we check for every block which has been deallocated that it is still
filled with CharToUseToWipeOut.
Warning: this is VERY time-consuming
This is meaningful only when the blocks are wiped out on free mem
This is incompatible with dangling interfaces checking}
DoNotCheckWipedBlocksBiggerThan = 4000;
CollectStatsAboutObjectAllocation = False;
{Every time FreeMem is called for allocationg an object, this will register information about the class instanciated:
class name, number of instances, allocated space for one instance
Note: this has to be done on FreeMem because when GetMem is called, the VMT is not installed yet and we can not know
this is an object}
KeepMaxMemoryUsage = CollectStatsAboutObjectAllocation;
{Will report the biggest memory usage during the execution}
ComputeMemoryUsageStats = False;
{Outputs the memory usage along the life of the execution. This output can be easily graphed, in excel for example}
MemoryUsageStatsStep = 5;
{Meaningful only when ComputeMemoryUsageStats
When this is set to 5, we collect information for the stats every 5 call to GetMem, unless size is bigger than StatCollectionForce}
StatCollectionForce = 1000;
// (MClass, MUser, MReallocedUser);
BlocksToShow: TBlocksToShow = ({MClass=}True, {MUser=}True, {MReallocedUser=}True);
{eg if BlocksToShow[MClass] is True, the blocks allocated for class instances will be shown}
CheckHeapStatus = False;
// Checks that the heap has not been corrupted since last call to the memory manager
// Warning: VERY time-consuming
IdentifyObjectFields = False;
IdentifyFieldsOfObjectsConformantTo: TClass = TObject;
MaxLeak = 1000;
{This option tells to MemCheck not to display more than a certain quantity of leaks, so that the finalization
phase does not take too long}
UseDebugInfos = True;
//Should use the debug informations which are in the executable ?
RaiseExceptionsOnEnd = True;
//Should we use exceptions to show memory leak information ?
{+}
NoLogWhenZeroNoLeaks = True; { Optional }
{+.}
NotepadApp = 'notepad';
//The application launched to show the log file
(**************** END OF MEMCHECK OPTIONS ********************)
var
ShowCallStack: Boolean;
{When we show an allocated block, should we show the call stack that went to the allocation ? Set to false
before each block. The usual way to use this is calling Evaluate/Modify just after an EMemoryLeak was raised}
const
MaxListSize = MaxInt div 16 - 1;
type
PObjectsArray = ^TObjectsArray;
TObjectsArray = array[0..MaxListSize] of TObject;
PStringsArray = ^TStringsArray;
TStringsArray = array[0..99999999] of string;
{Used to simulate string lists}
PIntegersArray = ^TIntegersArray;
TIntegersArray = array[0..99999999] of Integer;
{Used to simulate lists of integer}
var
TimeStamps: PStringsArray = nil;
{Allows associating a string of information with a time stamp}
TimeStampsCount: Integer = 0;
{Number of time stamps in the array}
TimeStampsAllocated: Integer = 0;
{Number of positions available in the array}
const
DeallocateInstancesConformingTo = False;
InstancesConformingToForDeallocation: TClass = TObject;
{used only when BlocksToShow[MClass] is True - eg If InstancesConformingTo = TList, only blocks allocated for instances
of TList and its heirs will be shown}
InstancesConformingToForReporting: TClass = TObject;
{used only when BlocksToShow[MClass] is True - eg If InstancesConformingTo = TList, only blocks allocated for instances
of TList and its heirs will be shown}
MaxNbSupportedVMTEntries = 200;
{Don't change this number, its a Hack! jm}
type
PMemoryBlockHeader = ^TMemoryBlockHeader;
TMemoryBlockHeader = packed record
{
This is the header we put in front of a memory block
For each memory allocation, we allocate "size requested + header size + footer size" because we keep information inside the memory zone.
Therefore, the address returned by GetMem is: [the address we get from OldMemoryManager.GetMem] + HeaderSize.
. DestructionAdress: an identifier telling if the bloc is active or not (when FreeMem is called we do not really free the mem).
Nil when the block has not been freed yet; otherwise, contains the address of the caller of the destruction. This will be useful
for reporting errors such as "this memory has already been freed, at address XXX".
. PreceedingBlock: link of the linked list of allocated blocs
. NextBlock: link of the linked list of allocated blocs
. KindOfBlock: is the data an object or unknown kind of data (such as a buffer)
. VMT: the classtype of the object
. CallerAddress: an array containing the call stack at allocation time
. AllocatedSize: the size allocated for the user (size requested by the user)
. MagicNumber: an integer we use to recognize a block which was allocated using our own allocator
}
// // SizeOf , Summa
DestructionAdress: Pointer; // 4 , 4
PreceedingBlock: Pointer; // 4 , 8
NextBlock: Pointer; // 4 , 12
KindOfBlock: TKindOfMemory; // 1 , 13 // need option: {$MINENUMSIZE 1}
{+}
// IgnoreTrace - mark block memory to ignore leak information
IgnoreTrace: Byte; // 1 , 14
// LeakTransaction - fragmentation reports of leaks
LeakTransaction: Cardinal; // 4 , 18
{+.}
VMT: TClass; // 4 , 22
CallerAddress: TCallStack; // 108 , 130
// AllocatedSize: this is an integer because the parameter of GetMem is an integer
AllocatedSize: Integer; // 4 , 134
// LastTimeStamp: -1 means no time stamp
LastTimeStamp: Integer; // 4 , 138
// NotUsed: use for align TMemoryBlockHeader to 8: SizeOf(TMemoryBlockHeader) in MemCheck should be a multiple of 8
NotUsed: array [0..1] of Byte; // 2 , 140
MagicNumber: Cardinal; // 4 , 144
end;
{+}
// Check: SizeOf(TMemoryBlockHeader) in MemCheck should be a multiple of 8
TCheck_SizeOf_TMemoryBlockHeader_mod8 = array [SizeOf(TMemoryBlockHeader) mod 8 .. 0] of Byte;
{+.}
PMemoryBlockFooter = ^TMemoryBlockFooter;
TMemoryBlockFooter = Cardinal;
{This is the end-of-bloc marker we use to check that the user did not write beyond the allowed space}
EMemoryLeak = class(Exception);
EStackUnwinding = class(EMemoryLeak);
EBadInstance = class(Exception);
{This exception is raised when a virtual method is called on an object which has been freed}
EFreedBlockDamaged = class(Exception);
EInterfaceFreedInstance = class(Exception);
{This exception is raised when a method is called on an interface whom object has been freed}
VMTTable = array[0..MaxNbSupportedVMTEntries] of Pointer;
pVMTTable = ^VMTTable;
TMyVMT = record
A: array[0..19] of Byte;
B: VMTTable;
end;
ReleasedInstance = class
procedure RaiseExcept;
procedure InterfaceError; stdcall;
procedure Error; virtual;
end;
TFieldInfo = class
OwnerClass: TClass;
FieldIndex: Integer;
constructor Create(const TheOwnerClass: TClass; const TheFieldIndex: Integer);
end;
const
{+}
//SizeOf_TMemoryBlockHeader = (SizeOf(TMemoryBlockHeader) + 7) div 8 * 8; // Align SizeOf(TMemoryBlockHeader) to 8
SizeOf_TMemoryBlockHeader = SizeOf(TMemoryBlockHeader);
{+.}
EndOfBlock: Cardinal = $FFFFFFFA;
Magic: Cardinal = $FFFFFFFF;
var
FreedInstance: PAnsiChar;
BadObjectVMT: TMyVMT;
BadInterfaceVMT: VMTTable;
GIndex: Integer;
LastBlock: PMemoryBlockHeader;
MemCheckActive: Boolean = False;
{Is MemCheck currently running ?
ie, is the current memory manager memcheck's ?}
MemCheckInitialized: Integer = -1;
{Has InitializeOnce been called ?
This variable should ONLY be used by InitializeOnce and the finalization}
{*** arrays for stats ***}
AllocatedObjectsClasses: array of TClass;
NbClasses: Integer = 0;
AllocatedInstances: PIntegersArray = nil; {instances counter}
AllocStatsCount: Integer = 0;
StatsArraysAllocatedPos: Integer = 0;
{This is used to display some statistics about objects allocated. Each time an object is allocated, we look if its
class name appears in this list. If it does, we increment the counter of class' instances for this class;
if it does not appear, we had it with a counter set to one.}
MemoryUsageStats: PIntegersArray = nil; {instances counter}
MemoryUsageStatsCount: Integer = 0;
MemoryUsageStatsAllocatedPos: Integer = 0;
MemoryUsageStatsLoop: Integer = -1;
SevereExceptionsLogFile: Text;
{This is the log file for exceptions}
OutOfMemory: EOutOfMemory;
// Because when we have to raise this, we do not want to have to instanciate it (as there is no memory available)
HeapCorrupted: Exception;
NotDestroyedFields: PIntegersArray = nil;
NotDestroyedFieldsInfos: PObjectsArray = nil;
NotDestroyedFieldsCount: Integer = 0;
NotDestroyedFieldsAllocatedSpace: Integer = 0;
LastHeapStatus: THeapStatus;
MaxMemoryUsage: Integer = 0;
// see KeepMaxMemoryUsage
type
TMemoryManagerRec = {$IFDEF D10_UP}TMemoryManagerEx{$ELSE}TMemoryManager{$ENDIF};
var
OldMemoryManager: TMemoryManagerRec;
//Set by the MemChk routine
type
TIntegerBinaryTree = class
protected
fValue: Cardinal;
fBigger: TIntegerBinaryTree;
fSmaller: TIntegerBinaryTree;
class function StoredValue(const Address: Cardinal): Cardinal;
constructor _Create(const Address: Cardinal);
function _Has(const Address: Cardinal): Boolean;
procedure _Add(const Address: Cardinal);
procedure _Remove(const Address: Cardinal);
public
function Has(const Address: Cardinal): Boolean;
procedure Add(const Address: Cardinal);
procedure Remove(const Address: Cardinal);
property Value: Cardinal read fValue;
end;
PCardinal = ^Cardinal;
var
CurrentlyAllocatedBlocksTree: TIntegerBinaryTree;
type
TAddressToLine = class
public
Address: Cardinal;
Line: Cardinal;
constructor Create(const AAddress, ALine: Cardinal);
end;
PAddressesArray = ^TAddressesArray;
TAddressesArray = array[0..MaxListSize] of TAddressToLine;
TUnitDebugInfos = class
public
Name: string;
Addresses: array of TAddressToLine;
constructor Create(const AName: string; const NbLines: Cardinal);
function LineNumWhichContainsAddress(const Address: Cardinal): Cardinal;
function LineWhichContainsAddress(const Address: Cardinal): string;
end;
TRoutineDebugInfos = class
public
Name: string;
StartAddress: Cardinal;
EndAddress: Cardinal;
constructor Create(const AName: string; const AStartAddress: Cardinal; const ALength: Cardinal);
end;
var
Routines: array of TRoutineDebugInfos;
RoutinesCount: Integer;
Units: array of TUnitDebugInfos;
UnitsCount: Integer;
OutputFileHeader: string = 'MemCheck version ' + MemCheckVersion + #13#10;
HeapStatusSynchro: TSynchroObject;
{+}
{$IFNDEF D6_UP}
const
sLineBreak = AnsiString(#13#10);
{$ENDIF}
{$IFDEF USE_JEDI}
{$IFDEF USE_JEDI_DLL}
const
JclDbgMapOfAddr = 'JclDbgMapOfAddr.dll';
type
TGetDbgInfoByAddrW = function (const Addr: Pointer; var WFile, WModule, WProc: WideString; var ALine: Integer): Boolean;
PGetDbgInfoByAddrW = ^TGetDbgInfoByAddrW;
function GetDbgInfoByAddrWNone(const Addr: Pointer; var WFile, WModule, WProc: WideString; var ALine: Integer): Boolean;
begin
Result := False;
end;
function GetDbgInfoByAddrWFirst(const Addr: Pointer; var WFile, WModule, WProc: WideString; var ALine: Integer): Boolean; forward;
var
GetDbgInfoByAddrW: TGetDbgInfoByAddrW = GetDbgInfoByAddrWFirst;
GetDbgInfoByAddrWDynamic: TGetDbgInfoByAddrW;
function GetDbgInfoByAddrWSafe(const Addr: Pointer; var WFile, WModule, WProc: WideString; var ALine: Integer): Boolean;
begin
try
Result := GetDbgInfoByAddrWDynamic(Addr, WFile, WModule, WProc, ALine);
except
GetDbgInfoByAddrW := GetDbgInfoByAddrWNone;
Result := False;
end;
end;
function GetDbgInfoByAddrWFirst(const Addr: Pointer; var WFile, WModule, WProc: WideString; var ALine: Integer): Boolean;
var
H: Integer;
P: Pointer;
begin
Result := False;
GetDbgInfoByAddrW := GetDbgInfoByAddrWNone;
H := LoadLibrary(JclDbgMapOfAddr);
if H <> 0 then
begin
P := GetProcAddress(H, 'GetMapOfAddrW');
if P <> nil then
begin
@GetDbgInfoByAddrWDynamic := PGetDbgInfoByAddrW(p);
@GetDbgInfoByAddrW := @GetDbgInfoByAddrWSafe;
Result := GetDbgInfoByAddrW(Addr, WFile, WModule, WProc, ALine);
end;
end;
end;
function GetDbgInfoByAddrS(const Addr: Pointer; var AFile, AModule, AProc: string; var ALine: Integer): Boolean;
var
WFile, WModule, WProc: WideString;
begin
Result := GetDbgInfoByAddrW(Addr, WFile, WModule, WProc, ALine);
if Result then
begin
AFile := WFile;
AModule := WModule;
AProc := WProc;
end;
end;
{$ELSE ~USE_JEDI_DLL}
function GetDbgInfoByAddrS(const Addr: Pointer; var AFile, AModule, AProc: string; var ALine: Integer): Boolean;
begin
ALine := 0;
try
Result := JclDebug.MapOfAddr(Addr, AFile, AModule, AProc, ALine);
except
Result := False;
end;
if not Result then
begin
AFile := '';
AModule := '';
AProc := '';
end;
end;
{$ENDIF USE_JEDI_DLL}
{$ELSE ~USE_JEDI}
function GetDbgInfoByAddrS(const Addr: Pointer; var AFile, AModule, AProc: string; var ALine: Integer): Boolean; forward;
{$ENDIF USE_JEDI}
{+.}
function BlockAllocationAddress(p: Pointer): Pointer;
var
Block: PMemoryBlockHeader;
begin
Block := PMemoryBlockHeader(PAnsiChar(p) - SizeOf_TMemoryBlockHeader);
if Block.MagicNumber = Magic then
Result := Block.CallerAddress[0]
else
Result := nil;
end;
procedure UpdateLastHeapStatus;
begin
LastHeapStatus := GetHeapStatus;
end;
function HeapStatusesDifferent(const Old, New: THeapStatus): Boolean;
begin
Result :=
(Old.TotalAddrSpace <> New.TotalAddrSpace) or
(Old.TotalUncommitted <> New.TotalUncommitted) or
(Old.TotalCommitted <> New.TotalCommitted) or
(Old.TotalAllocated <> New.TotalAllocated) or
(Old.TotalFree <> New.TotalFree) or
(Old.FreeSmall <> New.FreeSmall) or
(Old.FreeBig <> New.FreeBig) or
(Old.Unused <> New.Unused) or
(Old.Overhead <> New.Overhead) or
(Old.HeapErrorCode <> New.HeapErrorCode) or
(New.TotalUncommitted + New.TotalCommitted <> New.TotalAddrSpace) or
(New.Unused + New.FreeBig + New.FreeSmall <> New.TotalFree)
end;
class function TIntegerBinaryTree.StoredValue(const Address: Cardinal): Cardinal;
begin
Result := Address shl 16;
Result := Result or (Address shr 16);
Result := Result xor $AAAAAAAA;
end;
constructor TIntegerBinaryTree._Create(const Address: Cardinal);
begin //We do not call inherited Create for optimization
fValue := Address
end;
function TIntegerBinaryTree.Has(const Address: Cardinal): Boolean;
begin
Result := _Has(StoredValue(Address));
end;
procedure TIntegerBinaryTree.Add(const Address: Cardinal);
begin
_Add(StoredValue(Address));
end;
procedure TIntegerBinaryTree.Remove(const Address: Cardinal);
begin
_Remove(StoredValue(Address));
end;
function TIntegerBinaryTree._Has(const Address: Cardinal): Boolean;
begin
if fValue = Address then
Result := True
else if (Address > fValue) and (fBigger <> nil) then
Result := fBigger._Has(Address)
else if (Address < fValue) and (fSmaller <> nil) then
Result := fSmaller._Has(Address)
else
Result := False
end;
procedure TIntegerBinaryTree._Add(const Address: Cardinal);
begin
Assert(Address <> fValue, 'TIntegerBinaryTree._Add: already in !');
if (Address > fValue) then
begin
if fBigger <> nil then
fBigger._Add(Address)
else
fBigger := TIntegerBinaryTree._Create(Address)
end
else
begin
if fSmaller <> nil then
fSmaller._Add(Address)
else
fSmaller := TIntegerBinaryTree._Create(Address)
end
end;
procedure TIntegerBinaryTree._Remove(const Address: Cardinal);
var
Owner, Node: TIntegerBinaryTree;
NodeIsOwnersBigger: Boolean;
Middle, MiddleOwner: TIntegerBinaryTree;
begin
Owner := nil;
Node := CurrentlyAllocatedBlocksTree;
while (Node <> nil) and (Node.fValue <> Address) do
begin
Owner := Node;
if Address > Node.Value then
Node := Node.fBigger
else
Node := Node.fSmaller
end;
Assert(Node <> nil, 'TIntegerBinaryTree._Remove: not in');
NodeIsOwnersBigger := Node = Owner.fBigger;
if Node.fBigger = nil then
begin