From 2989065ea677fe30bfa1021e327b876c1a2e6855 Mon Sep 17 00:00:00 2001 From: Robert Dewar Date: Tue, 15 Nov 2005 14:59:11 +0100 Subject: [PATCH] g-debpoo.adb (Set_Valid): Use Integer_Address instead of Storage_Offset to avoid wrap around causing... 2005-11-14 Robert Dewar * g-debpoo.adb (Set_Valid): Use Integer_Address instead of Storage_Offset to avoid wrap around causing invalid results. From-SVN: r106981 --- gcc/ada/g-debpoo.adb | 152 +++++++++++++++++++++++++++++---------------------- 1 file changed, 87 insertions(+), 65 deletions(-) diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb index eeb36a2..1854623 100644 --- a/gcc/ada/g-debpoo.adb +++ b/gcc/ada/g-debpoo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -47,7 +47,7 @@ with Ada.Unchecked_Conversion; package body GNAT.Debug_Pools is - Default_Alignment : constant Storage_Offset := Standard'Maximum_Alignment; + Default_Alignment : constant := Standard'Maximum_Alignment; -- Alignment used for the memory chunks returned by Allocate. Using this -- value garantees that this alignment will be compatible with all types -- and at the same time makes it easy to find the location of the extra @@ -63,14 +63,15 @@ package body GNAT.Debug_Pools is -- Maximum number of levels that will be ignored in backtraces. This is so -- that we still have enough significant levels in the tracebacks returned -- to the user. + -- -- The value 10 is chosen as being greater than the maximum callgraph -- in this package. Its actual value is not really relevant, as long as it -- is high enough to make sure we still have enough frames to return to -- the user after we have hidden the frames internal to this package. - ----------------------- - -- Tracebacks_Htable -- - ----------------------- + --------------------------- + -- Back Trace Hash Table -- + --------------------------- -- This package needs to store one set of tracebacks for each allocation -- point (when was it allocated or deallocated). This would use too much @@ -103,19 +104,28 @@ package body GNAT.Debug_Pools is Next : Traceback_Htable_Elem_Ptr; end record; + -- Subprograms used for the Backtrace_Htable instantiation + procedure Set_Next (E : Traceback_Htable_Elem_Ptr; Next : Traceback_Htable_Elem_Ptr); + pragma Inline (Set_Next); + function Next - (E : Traceback_Htable_Elem_Ptr) - return Traceback_Htable_Elem_Ptr; + (E : Traceback_Htable_Elem_Ptr) return Traceback_Htable_Elem_Ptr; + pragma Inline (Next); + function Get_Key - (E : Traceback_Htable_Elem_Ptr) - return Tracebacks_Array_Access; + (E : Traceback_Htable_Elem_Ptr) return Tracebacks_Array_Access; + pragma Inline (Get_Key); + function Hash (T : Tracebacks_Array_Access) return Header; + pragma Inline (Hash); + function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean; - pragma Inline (Set_Next, Next, Get_Key, Hash); - -- Subprograms required for instantiation of the htable. See GNAT.HTable. + -- Why is this not inlined??? + + -- The hash table for back traces package Backtrace_Htable is new GNAT.HTable.Static_HTable (Header_Num => Header, @@ -136,24 +146,26 @@ package body GNAT.Debug_Pools is type Allocation_Header; type Allocation_Header_Access is access Allocation_Header; - -- The following record stores extra information that needs to be - -- memorized for each block allocated with the special debug pool. - type Traceback_Ptr_Or_Address is new System.Address; -- A type that acts as a C union, and is either a System.Address or a -- Traceback_Htable_Elem_Ptr. + -- The following record stores extra information that needs to be + -- memorized for each block allocated with the special debug pool. + type Allocation_Header is record Allocation_Address : System.Address; - -- Address of the block returned by malloc, possibly unaligned. + -- Address of the block returned by malloc, possibly unaligned - Block_Size : Storage_Offset; + Block_Size : Storage_Offset; -- Needed only for advanced freeing algorithms (traverse all allocated -- blocks for potential references). This value is negated when the -- chunk of memory has been logically freed by the application. This -- chunk has not been physically released yet. - Alloc_Traceback : Traceback_Htable_Elem_Ptr; + Alloc_Traceback : Traceback_Htable_Elem_Ptr; + -- ??? comment required + Dealloc_Traceback : Traceback_Ptr_Or_Address; -- Pointer to the traceback for the allocation (if the memory chunk is -- still valid), or to the first deallocation otherwise. Make sure this @@ -177,22 +189,24 @@ package body GNAT.Debug_Pools is function To_Address is new Ada.Unchecked_Conversion (Traceback_Ptr_Or_Address, System.Address); + function To_Address is new Ada.Unchecked_Conversion (System.Address, Traceback_Ptr_Or_Address); + function To_Traceback is new Ada.Unchecked_Conversion (Traceback_Ptr_Or_Address, Traceback_Htable_Elem_Ptr); + function To_Traceback is new Ada.Unchecked_Conversion (Traceback_Htable_Elem_Ptr, Traceback_Ptr_Or_Address); - Header_Offset : constant Storage_Count - := Default_Alignment * - ((Allocation_Header'Size / System.Storage_Unit + Default_Alignment - 1) - / Default_Alignment); - -- Offset of user data after allocation header. + Header_Offset : constant Storage_Count := + Default_Alignment * + ((Allocation_Header'Size / System.Storage_Unit + + Default_Alignment - 1) / Default_Alignment); + -- Offset of user data after allocation header Minimum_Allocation : constant Storage_Count := - Default_Alignment - 1 - + Header_Offset; + Default_Alignment - 1 + Header_Offset; -- Minimal allocation: size of allocation_header rounded up to next -- multiple of default alignment + worst-case padding. @@ -200,14 +214,14 @@ package body GNAT.Debug_Pools is -- Allocations table -- ----------------------- - -- This table is indexed on addresses modulo Default_Alignment, and - -- for each index it indicates whether that memory block is valid. - -- Its behavior is similar to GNAT.Table, except that we need to pack - -- the table to save space, so we cannot reuse GNAT.Table as is. + -- This table is indexed on addresses modulo Default_Alignment, and for + -- each index it indicates whether that memory block is valid. Its behavior + -- is similar to GNAT.Table, except that we need to pack the table to save + -- space, so we cannot reuse GNAT.Table as is. - -- This table is the reason why all alignments have to be forced to a - -- common value (Default_Alignment), so that this table can be - -- kept to a reasonnable size. + -- This table is the reason why all alignments have to be forced to common + -- value (Default_Alignment), so that this table can be kept to a + -- reasonnable size. type Byte is mod 2 ** System.Storage_Unit; @@ -242,18 +256,17 @@ package body GNAT.Debug_Pools is -- These two variables represents a mapping of the currently allocated -- memory. Every time the pool works on an address, we first check that the -- index Address / Default_Alignment is True. If not, this means that this - -- address is not under control of the debug pool, and thus this is - -- probably an invalid memory access (it could also be a general access - -- type). + -- address is not under control of the debug pool and thus this is probably + -- an invalid memory access (it could also be a general access type). -- -- Note that in fact we never allocate the full size of Big_Table, only a -- slice big enough to manage the currently allocated memory. - Edata : System.Address := System.Null_Address; + Edata : System.Address := System.Null_Address; -- Address in memory that matches the index 0 in Valid_Blocks. It is named -- after the symbol _edata, which, on most systems, indicate the lowest - -- possible address returned by malloc. Unfortunately, this symbol - -- doesn't exist on windows, so we cannot use it instead of this variable. + -- possible address returned by malloc. Unfortunately, this symbol doesn't + -- exist on windows, so we cannot use it instead of this variable. ----------------------- -- Local subprograms -- @@ -264,16 +277,15 @@ package body GNAT.Debug_Pools is Kind : Traceback_Kind; Size : Storage_Count; Ignored_Frame_Start : System.Address; - Ignored_Frame_End : System.Address) - return Traceback_Htable_Elem_Ptr; + Ignored_Frame_End : System.Address) return Traceback_Htable_Elem_Ptr; -- Return an element matching the current traceback (omitting the frames -- that are in the current package). If this traceback already existed in -- the htable, a pointer to this is returned to spare memory. Null is -- returned if the pool is set not to store tracebacks. If the traceback -- already existed in the table, the count is incremented so that - -- Dump_Tracebacks returns useful results. - -- All addresses up to, and including, an address between - -- Ignored_Frame_Start .. Ignored_Frame_End are ignored. + -- Dump_Tracebacks returns useful results. All addresses up to, and + -- including, an address between Ignored_Frame_Start .. Ignored_Frame_End + -- are ignored. procedure Put_Line (Depth : Natural; @@ -364,9 +376,7 @@ package body GNAT.Debug_Pools is ---------- function Next - (E : Traceback_Htable_Elem_Ptr) - return Traceback_Htable_Elem_Ptr - is + (E : Traceback_Htable_Elem_Ptr) return Traceback_Htable_Elem_Ptr is begin return E.Next; end Next; @@ -386,8 +396,7 @@ package body GNAT.Debug_Pools is ------------- function Get_Key - (E : Traceback_Htable_Elem_Ptr) - return Tracebacks_Array_Access + (E : Traceback_Htable_Elem_Ptr) return Tracebacks_Array_Access is begin return E.Traceback; @@ -399,10 +408,12 @@ package body GNAT.Debug_Pools is function Hash (T : Tracebacks_Array_Access) return Header is Result : Integer_Address := 0; + begin for X in T'Range loop Result := Result + To_Integer (PC_For (T (X))); end loop; + return Header (1 + Result mod Integer_Address (Header'Last)); end Hash; @@ -496,8 +507,7 @@ package body GNAT.Debug_Pools is Kind : Traceback_Kind; Size : Storage_Count; Ignored_Frame_Start : System.Address; - Ignored_Frame_End : System.Address) - return Traceback_Htable_Elem_Ptr + Ignored_Frame_End : System.Address) return Traceback_Htable_Elem_Ptr is begin if Pool.Stack_Trace_Depth = 0 then @@ -515,7 +525,7 @@ package body GNAT.Debug_Pools is Skip_Levels (Pool.Stack_Trace_Depth, Trace, Start, Len, Ignored_Frame_Start, Ignored_Frame_End); - -- Check if the traceback is already in the table. + -- Check if the traceback is already in the table Elem := Backtrace_Htable.Get (Trace (Start .. Len)'Unrestricted_Access); @@ -547,9 +557,7 @@ package body GNAT.Debug_Pools is function Is_Valid (Storage : System.Address) return Boolean is Offset : constant Storage_Offset := (Storage - Edata) / Default_Alignment; - Bit : constant Byte := 2 ** Natural (Offset mod System.Storage_Unit); - begin return (Storage mod Default_Alignment) = 0 and then Offset >= 0 @@ -621,13 +629,27 @@ package body GNAT.Debug_Pools is Valid_Blocks_Size := Valid_Blocks_Size + Bytes; -- Take into the account the new start address + Edata := Storage - Edata_Align + (Edata - Storage) mod Edata_Align; end if; -- Second case : the new address is outside of the current scope of - -- Valid_Blocks, so we have to grow the table as appropriate + -- Valid_Blocks, so we have to grow the table as appropriate. - Offset := (Storage - Edata) / Default_Alignment; + -- Note: it might seem more natural for the following statement to + -- be written: + + -- Offset := (Storage - Edata) / Default_Alignment; + + -- but that won't work since Storage_Offset is signed, and it is + -- possible to subtract a small address from a large address and + -- get a negative value. This may seem strange, but it is quite + -- specifically allowed in the RM, and is what most implementations + -- including GNAT actually do. Hence the conversion to Integer_Address + -- which is a full range modular type, not subject to this glitch. + + Offset := Storage_Offset ((To_Integer (Storage) - To_Integer (Edata)) / + Default_Alignment); if Offset >= Valid_Blocks_Size * System.Storage_Unit then Bytes := Valid_Blocks_Size; @@ -717,10 +739,12 @@ package body GNAT.Debug_Pools is P := new Local_Storage_Array; end; - Storage_Address := System.Null_Address + Default_Alignment - * (((P.all'Address + Default_Alignment - 1) - System.Null_Address) - / Default_Alignment) + Storage_Address := + System.Null_Address + Default_Alignment + * (((P.all'Address + Default_Alignment - 1) - System.Null_Address) + / Default_Alignment) + Header_Offset; + pragma Assert ((Storage_Address - System.Null_Address) mod Default_Alignment = 0); pragma Assert (Storage_Address + Size_In_Storage_Elements @@ -940,7 +964,7 @@ package body GNAT.Debug_Pools is System.Memory.Free (Header.Allocation_Address); Set_Valid (Tmp, False); - -- Remove this block from the list. + -- Remove this block from the list if Previous = System.Null_Address then Pool.First_Free_Block := Next; @@ -1038,7 +1062,6 @@ package body GNAT.Debug_Pools is procedure Reset_Marks is Current : System.Address := Pool.First_Free_Block; Header : Allocation_Header_Access; - begin while Current /= System.Null_Address loop Header := Header_Of (Current); @@ -1126,7 +1149,7 @@ package body GNAT.Debug_Pools is end if; else - -- Remove this block from the list of used blocks. + -- Remove this block from the list of used blocks Previous := To_Address (Header_Of (Storage_Address).Dealloc_Traceback); @@ -1459,7 +1482,6 @@ package body GNAT.Debug_Pools is function Storage_Size (Pool : Debug_Pool) return Storage_Count is pragma Unreferenced (Pool); - begin return Storage_Count'Last; end Storage_Size; @@ -1535,7 +1557,6 @@ package body GNAT.Debug_Pools is procedure Internal is new Print_Info (Put_Line => GNAT.IO.Put_Line, Put => GNAT.IO.Put); - begin Internal (Pool, Cumulate, Display_Slots, Display_Leaks); end Print_Info_Stdout; @@ -1594,9 +1615,10 @@ package body GNAT.Debug_Pools is Tracebk := Header.Alloc_Traceback.Traceback; Num_Calls := Tracebk'Length; - -- Code taken from memtrack.adb in GNAT's sources - -- Logs allocation call - -- format is: + -- (Code taken from memtrack.adb in GNAT's sources) + + -- Logs allocation call using the format: + -- 'A' ... fputc (Character'Pos ('A'), File); -- 2.7.4