View Issue Details

IDProjectCategoryView StatusLast Update
0031462FPCRTLpublic2017-07-28 01:08
ReporterrunewalshAssigned ToMichael Van Canneyt 
PrioritynormalSeverityminorReproducibilitysometimes
Status resolvedResolutionfixed 
Product VersionProduct Build 
Target Version3.2.0Fixed in Version3.1.1 
Summary0031462: heap.inc: SysReAllocMem should call Sys* counterparts instead of MemoryManager fields
DescriptionBecause presently, custom memory manager built on top of the default one ends up receiving both its own and underlying chunks. The example fails for me in absence of heaptrc/cmem.
TagsNo tags attached.
Fixed in Revision36769
FPCOldBugId
FPCTarget
Attached Files
  • realloc.pas (4,055 bytes)
    {$mode objfpc} {$typedaddress on} {$coperators on}
    {-$define workaround}
    
    	procedure Halt;
    	begin
    		readln;
    		System.Halt;
    	end;
    
    {$ifdef workaround}
    {thread}var
    	NowReallocating: boolean;
    {$endif}
    
    type
    	// avoid memory management
    	StaticPointerSet = object
    		count: integer; // globals are zero-initialized
    		list: array[0 .. 9] of pointer;
    		procedure Add(p: pointer);
    		procedure Remove(p: pointer);
    		function Find(p: pointer): integer;
    		procedure Validate(p: pointer; const procname, whatpointer: string);
    	end;
    
    	procedure StaticPointerSet.Add(p: pointer);
    	begin
    		if count >= length(list) then
    		begin
    			writeln('FAIL: StaticPointerSet overflow (max ', length(list), ')');
    			Halt;
    		end;
    
    		inc(count);
    		list[count - 1] := p;
    	end;
    
    	procedure StaticPointerSet.Remove(p: pointer);
    	var
    		index: integer;
    	begin
    		index := Find(p);
    		if index < 0 then
    		begin
    			writeln('FAIL: StaticPointerSet: $', HexStr(p), ' not found');
    			Halt;
    		end;
    
    		list[index] := list[count - 1];
    		dec(count);
    	end;
    
    	function StaticPointerSet.Find(p: pointer): integer;
    	var
    		i: integer;
    	begin
    		for i := 0 to count - 1 do
    			if list[i] = p then
    				exit(i);
    		result := -1;
    	end;
    
    	procedure StaticPointerSet.Validate(p: pointer; const procname, whatpointer: string);
    	begin
    		if Find(p) < 0 then
    		begin
    			writeln('FAIL: ', procname, ' got wrong ''', whatpointer, ''' pointer $', HexStr(p));
    			Halt;
    		end;
    	end;
    
    const
    	ExtraSize = 16;
    
    var
    	UnderlyingPointers, FinalPointers: StaticPointerSet;
    	OldMgr, NewMgr: TMemoryManager;
    
    	function GetMemImpl(size: PtrUint): pointer;
    	begin
    	{$ifdef workaround} if NowReallocating then exit(OldMgr.GetMem(size)); {$endif}
    		result := OldMgr.GetMem(ExtraSize + size) + ExtraSize;
    		writeln('GetMem(', size, '): $', HexStr(result));
    
    		UnderlyingPointers.Add(result - ExtraSize);
    		FinalPointers.Add(result);
    	end;
    
    	function FreeMemImpl(p: pointer): PtrUint;
    	begin
    	{$ifdef workaround} if NowReallocating then exit(OldMgr.FreeMem(p)); {$endif}
    		writeln('FreeMem($', HexStr(p), ')');
    		FinalPointers.Validate(p, 'FreeMem', 'final');
    		UnderlyingPointers.Validate(p - ExtraSize, 'FreeMem', 'underlying');
    
    		result := OldMgr.FreeMem(p - ExtraSize);
    	end;
    
    	function ReallocMemImpl(var p: pointer; size: PtrUint): pointer;
    	var
    		t: pointer;
    	begin
    		if size = 0 then
    		begin
    			FreeMemImpl(p);
    			result := nil;
    		end else
    			if not Assigned(p) then
    				result := GetMemImpl(size)
    			else
    			begin
    				writeln('ReallocMem($', HexStr(p), ', ', size, ')');
    				FinalPointers.Validate(p, 'ReallocMem', 'final');
    				UnderlyingPointers.Validate(p - ExtraSize, 'ReallocMem', 'underlying');
    
    				FinalPointers.Remove(p);
    				UnderlyingPointers.Remove(p - ExtraSize);
    
    				t := p - ExtraSize;
    			{$ifdef workaround} NowReallocating := true; {$endif}
    				result := OldMgr.ReallocMem(t, ExtraSize + size) + ExtraSize;
    			{$ifdef workaround} NowReallocating := false; {$endif}
    				writeln('ReallocMem($', HexStr(p), ', ', size, ') = ', HexStr(result));
    
    				UnderlyingPointers.Add(result - ExtraSize);
    				FinalPointers.Add(result);
    			end;
    		p := result;
    	end;
    
    	function MemSizeImpl(p: pointer): PtrUint;
    	begin
    	{$ifdef workaround} if NowReallocating then exit(OldMgr.MemSize(p)); {$endif}
    		writeln('MemSize($', HexStr(p), ')');
    		FinalPointers.Validate(p, 'MemSize', 'final');
    		UnderlyingPointers.Validate(p - ExtraSize, 'MemSize', 'underlying');
    
    		result := OldMgr.MemSize(p - ExtraSize) - ExtraSize;
    	end;
    
    var
    	a: pointer;
    
    begin
    	GetMemoryManager((@OldMgr)^);
    	NewMgr.GetMem     := @GetMemImpl;
    	NewMgr.FreeMem    := @FreeMemImpl;
    	NewMgr.ReallocMem := @ReallocMemImpl;
    	NewMgr.MemSize    := @MemSizeImpl;
    	SetMemoryManager(NewMgr);
    
    	writeln('> a := GetMem(10);');      a := GetMem(10);
    	writeln(#10'> ReallocMem(a, 20);'); ReallocMem(a, 20);
    	writeln(#10'> FreeMem(a);');        FreeMem(a);
    	writeln(#10'OK');
    	readln;
    
    	SetMemoryManager(OldMgr);
    end.
    
    realloc.pas (4,055 bytes)

Activities

runewalsh

2017-03-01 18:33

reporter  

realloc.pas (4,055 bytes)
{$mode objfpc} {$typedaddress on} {$coperators on}
{-$define workaround}

	procedure Halt;
	begin
		readln;
		System.Halt;
	end;

{$ifdef workaround}
{thread}var
	NowReallocating: boolean;
{$endif}

type
	// avoid memory management
	StaticPointerSet = object
		count: integer; // globals are zero-initialized
		list: array[0 .. 9] of pointer;
		procedure Add(p: pointer);
		procedure Remove(p: pointer);
		function Find(p: pointer): integer;
		procedure Validate(p: pointer; const procname, whatpointer: string);
	end;

	procedure StaticPointerSet.Add(p: pointer);
	begin
		if count >= length(list) then
		begin
			writeln('FAIL: StaticPointerSet overflow (max ', length(list), ')');
			Halt;
		end;

		inc(count);
		list[count - 1] := p;
	end;

	procedure StaticPointerSet.Remove(p: pointer);
	var
		index: integer;
	begin
		index := Find(p);
		if index < 0 then
		begin
			writeln('FAIL: StaticPointerSet: $', HexStr(p), ' not found');
			Halt;
		end;

		list[index] := list[count - 1];
		dec(count);
	end;

	function StaticPointerSet.Find(p: pointer): integer;
	var
		i: integer;
	begin
		for i := 0 to count - 1 do
			if list[i] = p then
				exit(i);
		result := -1;
	end;

	procedure StaticPointerSet.Validate(p: pointer; const procname, whatpointer: string);
	begin
		if Find(p) < 0 then
		begin
			writeln('FAIL: ', procname, ' got wrong ''', whatpointer, ''' pointer $', HexStr(p));
			Halt;
		end;
	end;

const
	ExtraSize = 16;

var
	UnderlyingPointers, FinalPointers: StaticPointerSet;
	OldMgr, NewMgr: TMemoryManager;

	function GetMemImpl(size: PtrUint): pointer;
	begin
	{$ifdef workaround} if NowReallocating then exit(OldMgr.GetMem(size)); {$endif}
		result := OldMgr.GetMem(ExtraSize + size) + ExtraSize;
		writeln('GetMem(', size, '): $', HexStr(result));

		UnderlyingPointers.Add(result - ExtraSize);
		FinalPointers.Add(result);
	end;

	function FreeMemImpl(p: pointer): PtrUint;
	begin
	{$ifdef workaround} if NowReallocating then exit(OldMgr.FreeMem(p)); {$endif}
		writeln('FreeMem($', HexStr(p), ')');
		FinalPointers.Validate(p, 'FreeMem', 'final');
		UnderlyingPointers.Validate(p - ExtraSize, 'FreeMem', 'underlying');

		result := OldMgr.FreeMem(p - ExtraSize);
	end;

	function ReallocMemImpl(var p: pointer; size: PtrUint): pointer;
	var
		t: pointer;
	begin
		if size = 0 then
		begin
			FreeMemImpl(p);
			result := nil;
		end else
			if not Assigned(p) then
				result := GetMemImpl(size)
			else
			begin
				writeln('ReallocMem($', HexStr(p), ', ', size, ')');
				FinalPointers.Validate(p, 'ReallocMem', 'final');
				UnderlyingPointers.Validate(p - ExtraSize, 'ReallocMem', 'underlying');

				FinalPointers.Remove(p);
				UnderlyingPointers.Remove(p - ExtraSize);

				t := p - ExtraSize;
			{$ifdef workaround} NowReallocating := true; {$endif}
				result := OldMgr.ReallocMem(t, ExtraSize + size) + ExtraSize;
			{$ifdef workaround} NowReallocating := false; {$endif}
				writeln('ReallocMem($', HexStr(p), ', ', size, ') = ', HexStr(result));

				UnderlyingPointers.Add(result - ExtraSize);
				FinalPointers.Add(result);
			end;
		p := result;
	end;

	function MemSizeImpl(p: pointer): PtrUint;
	begin
	{$ifdef workaround} if NowReallocating then exit(OldMgr.MemSize(p)); {$endif}
		writeln('MemSize($', HexStr(p), ')');
		FinalPointers.Validate(p, 'MemSize', 'final');
		UnderlyingPointers.Validate(p - ExtraSize, 'MemSize', 'underlying');

		result := OldMgr.MemSize(p - ExtraSize) - ExtraSize;
	end;

var
	a: pointer;

begin
	GetMemoryManager((@OldMgr)^);
	NewMgr.GetMem     := @GetMemImpl;
	NewMgr.FreeMem    := @FreeMemImpl;
	NewMgr.ReallocMem := @ReallocMemImpl;
	NewMgr.MemSize    := @MemSizeImpl;
	SetMemoryManager(NewMgr);

	writeln('> a := GetMem(10);');      a := GetMem(10);
	writeln(#10'> ReallocMem(a, 20);'); ReallocMem(a, 20);
	writeln(#10'> FreeMem(a);');        FreeMem(a);
	writeln(#10'OK');
	readln;

	SetMemoryManager(OldMgr);
end.
realloc.pas (4,055 bytes)

Marco van de Voort

2017-03-02 12:27

manager   ~0098561

I wonder if this is supportable at all. If we/you change it you run into the next usecase for partial customization of the heapmanager.

If it is changed, the allowed usecases must be documented too.

runewalsh

2017-03-02 13:41

reporter   ~0098565

Last edited: 2017-03-02 21:27

View 2 revisions

You'd have to provide custom @GetMem/@FreeMem while keeping @SysReallocMem to make use of the current implementation, I believe no one relies on it.

Furthermore, SysReallocMem uses internal SysTryResizeMem routine which expects the pointer returned from SysGetMem and isn't even part of the memory manager interface.

Thus, I think it will be more consistent.

Thaddy de Koning

2017-03-03 11:00

reporter   ~0098590

Last edited: 2017-03-03 11:03

View 2 revisions

No. (dwarf) debug lineinfo requires a working heap manager.
That's why it is also no longer allowed to add heaptrc to the uses clause by hand, but only by specifying -gh. So everybody that uses heaptrc relies on it, pretty much everyone, I guess.
This is also documented.

If you want to partially specialize heaptrc.. it will still need to be called heaptrc, since only the compiler can load the associated memory manager in the right place.

Sven Barth

2017-03-03 16:29

manager   ~0098597

@Thaddy: no one is talking about heaptrc, but the heap manager. Two different things. Also we've always allowed to change the heap manager.

Thaddy de Koning

2017-03-04 09:26

reporter   ~0098618

Last edited: 2017-03-04 09:38

View 3 revisions

Sven, heaptrc needs *its own manager* installed for it to work. See TraceInit.

I concluded that you should not change the memory manager at all if you use heaptrc. And heaptrc should not be loaded by hand but by specifying -gh

So am I wrong to assume that you should not try and fiddle in extra's?

Especially since heap.inc says the following:
{ Do not use standard memory manager }
Which happens to be the one from heaptrc, which will break.

And reporter writes "The example fails for me in absence of heaptrc"

Furthermore the heaptrc manager uses SysTryResizeMem directly

runewalsh

2017-03-04 12:50

reporter   ~0098623

HeapTrc makes the example WORK because it overrides "buggy" SysReallocMem implementation with direct calls to SysGet/Free/TryResize counterparts, just like I propose.

With SysTryResizeMem, I'm pointing out the inconsistency of SysReallocMem: calls to the custom manager and to Sys* in one place shouldn't work at all, so I believe this "wrong" behavior being the only reason of HeapTrc redirecting to Sys* instead of old manager and, more important, of the inability for the user to extend the old manager in a general way.

Michael Van Canneyt

2017-07-23 11:29

administrator   ~0101866

I have changed the SysReallocMem to use Sys* routines.
This is more logical.

If memory serves well:
Current behaviour is probably a leftover from the time sysreallocmem was added to the memory manager, to allow previous memory manager overrides to continue to work without specifying a ReallocMem member. Meanwhile more members have been added which do not take this precaution.

I think we can leave these days behind us now, since the compiler now warns if you have a const record that does not specify values for all fields.

Issue History

Date Modified Username Field Change
2017-03-01 18:33 runewalsh New Issue
2017-03-01 18:33 runewalsh File Added: realloc.pas
2017-03-02 12:27 Marco van de Voort Note Added: 0098561
2017-03-02 13:41 runewalsh Note Added: 0098565
2017-03-02 21:27 runewalsh Note Edited: 0098565 View Revisions
2017-03-03 11:00 Thaddy de Koning Note Added: 0098590
2017-03-03 11:03 Thaddy de Koning Note Edited: 0098590 View Revisions
2017-03-03 16:29 Sven Barth Note Added: 0098597
2017-03-04 09:26 Thaddy de Koning Note Added: 0098618
2017-03-04 09:30 Thaddy de Koning Note Edited: 0098618 View Revisions
2017-03-04 09:38 Thaddy de Koning Note Edited: 0098618 View Revisions
2017-03-04 12:50 runewalsh Note Added: 0098623
2017-07-23 10:15 Michael Van Canneyt Assigned To => Michael Van Canneyt
2017-07-23 10:15 Michael Van Canneyt Status new => assigned
2017-07-23 11:29 Michael Van Canneyt Fixed in Revision => 36769
2017-07-23 11:29 Michael Van Canneyt Note Added: 0101866
2017-07-23 11:29 Michael Van Canneyt Status assigned => resolved
2017-07-23 11:29 Michael Van Canneyt Fixed in Version => 3.1.1
2017-07-23 11:29 Michael Van Canneyt Resolution open => fixed
2017-07-23 11:29 Michael Van Canneyt Target Version => 3.2.0