g-debpoo.adb (Set_Valid): Use Integer_Address instead of Storage_Offset to avoid…

g-debpoo.adb (Set_Valid): Use Integer_Address instead of Storage_Offset to avoid wrap around causing...

2005-11-14  Robert Dewar  <dewar@adacore.com>

	* 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

@@ -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,16 +146,16 @@ 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;
       --  Needed only for advanced freeing algorithms (traverse all allocated
@@ -154,6 +164,8 @@ package body GNAT.Debug_Pools is
       --  chunk has not been physically released yet.
 
       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,9 +256,8 @@ 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.
@@ -252,8 +265,8 @@ package body GNAT.Debug_Pools is
    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
+      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' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn>
 
          fputc (Character'Pos ('A'), File);