GNAT Allocation of a very large record

[hyunghwan.chung@gmail.com]

Hi, 

The program at the bottom of this message, when compiled with GNAT 4.6 on Ubuntu12/x86_64, seems to corrupt memory, ending up with a malloc error message.

$ ./x1
1. Kind: POINTER_OBJECT Size:  10
x1: malloc.c:2451: sYSMALLOc: Assertion `(old_top == (((mbinptr) (((char *) &((av)->bins[((1) - 1) * 2])) - __builtin_offsetof (struct malloc_chunk, fd)))) && old_size == 0) || ((unsigned long) (old_size) >= (unsigned long)((((__builtin_offsetof (struct malloc_chunk, fd_nextsize))+((2 * (sizeof(size_t))) - 1)) & ~((2 * (sizeof(size_t))) - 1))) && ((old_top)->size & 0x1) && ((unsigned long)old_end & pagemask) == 0)' failed.
^C

On some other platforms (i.e. debian/armv5tel, gcc/gnat 4.4.5), just segmentation fault.

I expect an output like this, meaning that the second call to 'new' should raise an exception like storage_error.

$ ./x1
1. Kind: POINTER_OBJECT Size:  10
2. Allocation Failed

You'd get the result like above if you changed the upper bound of the range of Pointer_Object_Size from Storage_Count'Last to  (OBJECT_DATA_BYTES / (Object_Pointer'Max_Size_In_Storage_Elements * System.Storage_Unit)).

The new upper bound has been defined so that Pointer_Object_Record'Size don't exceed 2 ** 63 - 1 (System.Max_Int). On an 32-bit platform, the upper bound seems to be able to reach OBJECT_DATA_BYTES / Object_Pointer'Max_Size_In_Storage_Elements. With this upper bound on the 32-bit platform, Pointer_Object_Record'Size may go beyond 2 ^ 31 - 1 but Pointer_Object_Record'Max_Size_In_Storage_Elements falls below 2 ^ 31 - 1. 

Anyway, when the upper bound is set to Storage_Count'Last, Pointer_Object_Record'Max_Size_In_Storage_Elements and Pointer_Object_Record'Size seem to wrap around to an undesired value

The problem is that neither Constraint_Error nor Storage_Error is raised when the size of a record is very large. I'd like to have a graceful way to catch a ridiculously large size given to the function and handle the exception properly without ending up with segmentation fault or something similar.

Is it a bug of the GNU Ada compiler or am i doing anything wrong?

Thanks,
Hyung-Hwan

------------------------------------------------------------------------------- 
with Ada.Text_IO; 
with System;
with Ada.Unchecked_Conversion;

procedure X1 is

	type Storage_Element is mod 2 ** System.Storage_Unit;
	for Storage_Element'Size use System.Storage_Unit;
	type Storage_Offset is range -(2 ** (System.Word_Size - 1)) ..  +(2 ** (System.Word_Size - 1)) - 1;
	subtype Storage_Count is Storage_Offset range 0 .. Storage_Offset'Last;

	subtype Object_Byte      is Storage_Element;
	subtype Object_Character is Wide_Character;
	subtype Object_String    is Wide_String;

	type Object_Kind is (Pointer_Object, Character_Object, Byte_Object);
	for Object_Kind use (Pointer_Object => 0, Character_Object => 1, Byte_Object => 2);

	type Object_Record;
	type Object_Pointer is access all Object_Record;

	type Byte_Array is array (Storage_Count range <>) of Object_Byte;
	type Character_Array is array (Storage_Count range <>) of Object_Character;
	type Pointer_Array is array (Storage_Count range <>) of Object_Pointer;

	type Object_Record (Kind: Object_Kind; Size: Storage_Count) is record
		Flags: Standard.Integer range 0 .. 3;-- := 0;
		Extra: Standard.Integer range 0 .. 1;-- := 0;
		Unit:  Standard.Integer range 0 .. 4;-- := 0;
		Class: Object_Pointer;-- := null;

		case Kind is
			when Pointer_Object =>
				Pointer_Slot: Pointer_Array (1 .. Size);-- := (Others => null);
			when Character_Object =>
				Character_Slot: Character_Array (0 .. Size);-- := (Others => Object_Character'Val(0));
			when Byte_Object =>
				Byte_Slot: Byte_Array (1 .. Size);-- := (Others => 0);
		end case;
	end record;
	for Object_Record use record
		Kind  at 0 range 0 .. 7;
		Flags at 1 range 0 .. 2;
		Extra at 1 range 3 .. 3;
		Unit  at 1 range 4 .. 7;
	end record;

	subtype Empty_Object_Record is Object_Record (Byte_Object, 0);
	-- the number of bytes in an object header. this is fixed in size
	OBJECT_HEADER_BYTES: constant Storage_Count := Empty_Object_Record'Max_Size_In_Storage_Elements;
	-- the largest number of bytes that an object can hold after the header
	OBJECT_DATA_BYTES: constant Storage_Count := Storage_Count'Last - OBJECT_HEADER_BYTES;

	subtype Pointer_Object_Size is Storage_Count range
		Storage_Count'First .. (OBJECT_DATA_BYTES / (Object_Pointer'Max_Size_In_Storage_Elements * System.Storage_Unit));
	--	Storage_Count'First .. Storage_Count'Last;

	procedure Alloc_Pointer_Object (Size: in Pointer_Object_Size; Result: out Object_Pointer) is
		subtype Pointer_Object_Record is Object_Record (Pointer_Object, Size);
		type Pointer_Object_Pointer is access Pointer_Object_Record;
		function To_Object_Pointer is new Ada.Unchecked_Conversion (Pointer_Object_Pointer, Object_Pointer);
		Ptr: Pointer_Object_Pointer;
	begin
   		--Ada.Text_IO.Put_Line (Pointer_Object_Record'Size'Img);
   		--Ada.Text_IO.Put_Line (Pointer_Object_Record'Max_Size_In_Storage_Elements'Img);
		Ptr := new Pointer_Object_Record'( 
			Kind => Pointer_Object, 
			Size => Size,
			Flags => 0,
			Extra => 0,
			Unit => 0,
			Class => null,
			Pointer_Slot => (others=>null)
		);

		Result := To_Object_Pointer (Ptr);
	exception
		when others =>
			Result := null;
	end Alloc_Pointer_Object;


	ObjPtr: Object_Pointer;
begin

	Alloc_Pointer_Object (10, ObjPtr);
	if ObjPtr = null then
		Ada.Text_IO.Put_Line ("1. Allocation Failed");
	else
		Ada.Text_IO.Put_Line ("1. Kind: " & Object_Kind'Image(ObjPtr.Kind)  & " Size: " & Storage_Count'Image(ObjPtr.Size));
	end if;

	Alloc_Pointer_Object (Pointer_Object_Size'Last, ObjPtr);
	if ObjPtr = null then
		Ada.Text_IO.Put_Line ("2. Allocation Failed");
	else
		Ada.Text_IO.Put_Line ("2. Kind: " & Object_Kind'Image(ObjPtr.Kind)  & " Size: " & Storage_Count'Image(ObjPtr.Size));
	end if;

end X1;