gcc/ada/g-debpoo.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                      G N A T . D E B U G _ P O O L S                     --
   6 --                                                                          --
   7 --                                B o d y                                   --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Unchecked_Conversion;
  35 with GNAT.HTable;
  36 with System.Memory;
  37
  38 pragma Elaborate_All (GNAT.HTable);
  39
  40 package body GNAT.Debug_Pools is
  41    use System;
  42    use System.Memory;
  43    use System.Storage_Elements;
  44
  45    --  Definition of a H-table storing the status of each storage chunck
  46    --  used by this pool
  47
  48    type State is (Not_Allocated, Deallocated, Allocated);
  49
  50    type Header is range 1 .. 1023;
  51    function H (F : Address) return Header;
  52
  53    package Table is new GNAT.HTable.Simple_HTable (
  54      Header_Num => Header,
  55      Element    => State,
  56      No_Element => Not_Allocated,
  57      Key        => Address,
  58      Hash       => H,
  59      Equal      => "=");
  60
  61    --------------
  62    -- Allocate --
  63    --------------
  64
  65    procedure Allocate
  66      (Pool                     : in out Debug_Pool;
  67       Storage_Address          : out Address;
  68       Size_In_Storage_Elements : Storage_Count;
  69       Alignment                : Storage_Count)
  70    is
  71       pragma Warnings (Off, Alignment);
  72
  73    begin
  74       Storage_Address := Alloc (size_t (Size_In_Storage_Elements));
  75
  76       if Storage_Address = Null_Address then
  77          raise Storage_Error;
  78       else
  79          Table.Set (Storage_Address, Allocated);
  80          Pool.Allocated := Pool.Allocated + Size_In_Storage_Elements;
  81
  82          if Pool.Allocated - Pool.Deallocated >  Pool.High_Water then
  83             Pool.High_Water := Pool.Allocated - Pool.Deallocated;
  84          end if;
  85       end if;
  86    end Allocate;
  87
  88    ----------------
  89    -- Deallocate --
  90    ----------------
  91
  92    procedure Deallocate
  93      (Pool                     : in out Debug_Pool;
  94       Storage_Address          : Address;
  95       Size_In_Storage_Elements : Storage_Count;
  96       Alignment                : Storage_Count)
  97    is
  98       pragma Warnings (Off, Alignment);
  99
 100       procedure Free (Address : System.Address; Siz : Storage_Count);
 101       --  Fake free, that resets all the deallocated storage to "DEADBEEF"
 102
 103       procedure Free (Address : System.Address; Siz : Storage_Count) is
 104          DB1 : constant Integer := 16#DEAD#;
 105          DB2 : constant Integer := 16#BEEF#;
 106
 107          type Dead_Memory is array (1 .. Siz / 4) of Integer;
 108          type Mem_Ptr is access all Dead_Memory;
 109
 110          function From_Ptr is
 111            new Unchecked_Conversion (System.Address, Mem_Ptr);
 112
 113          J : Storage_Offset;
 114
 115       begin
 116          J := Dead_Memory'First;
 117          while J < Dead_Memory'Last loop
 118             From_Ptr (Address) (J) := DB1;
 119             From_Ptr (Address) (J + 1) := DB2;
 120             J := J + 2;
 121          end loop;
 122
 123          if J = Dead_Memory'Last then
 124             From_Ptr (Address) (J) := DB1;
 125          end if;
 126       end Free;
 127
 128       S : State := Table.Get (Storage_Address);
 129
 130    --  Start of processing for Deallocate
 131
 132    begin
 133       case S is
 134          when Not_Allocated =>
 135             raise Freeing_Not_Allocated_Storage;
 136
 137          when Deallocated   =>
 138             raise  Freeing_Deallocated_Storage;
 139
 140          when Allocated =>
 141             Free (Storage_Address, Size_In_Storage_Elements);
 142             Table.Set (Storage_Address, Deallocated);
 143             Pool.Deallocated := Pool.Deallocated + Size_In_Storage_Elements;
 144       end case;
 145    end Deallocate;
 146
 147    -----------------
 148    -- Dereference --
 149    -----------------
 150
 151    procedure Dereference
 152      (Pool                     : in out Debug_Pool;
 153       Storage_Address          : Address;
 154       Size_In_Storage_Elements : Storage_Count;
 155       Alignment                : Storage_Count)
 156    is
 157       pragma Warnings (Off, Pool);
 158       pragma Warnings (Off, Size_In_Storage_Elements);
 159       pragma Warnings (Off, Alignment);
 160
 161       S       : State := Table.Get (Storage_Address);
 162       Max_Dim : constant := 3;
 163       Dim     : Integer  := 1;
 164
 165    begin
 166
 167       --  If this is not a known address, maybe it is because is is an
 168       --  unconstained array. In which case, the bounds have used the
 169       --  2 first words (per dimension) of the allocated spot.
 170
 171       while S = Not_Allocated and then Dim <= Max_Dim loop
 172          S := Table.Get (Storage_Address - Storage_Offset (Dim * 2 * 4));
 173          Dim := Dim + 1;
 174       end loop;
 175
 176       case S is
 177          when  Not_Allocated =>
 178             raise Accessing_Not_Allocated_Storage;
 179
 180          when Deallocated =>
 181             raise Accessing_Deallocated_Storage;
 182
 183          when Allocated =>
 184             null;
 185       end case;
 186    end Dereference;
 187
 188    -------
 189    -- H --
 190    -------
 191
 192    function H (F : Address) return Header is
 193    begin
 194       return
 195         Header (1 + (To_Integer (F) mod Integer_Address (Header'Last)));
 196    end H;
 197
 198    ----------------
 199    -- Print_Info --
 200    ----------------
 201
 202    procedure Print_Info (Pool : Debug_Pool) is
 203       use System.Storage_Elements;
 204
 205    begin
 206       Put_Line ("Debug Pool info:");
 207       Put_Line ("  Total allocated bytes : "
 208         & Storage_Offset'Image (Pool.Allocated));
 209
 210       Put_Line ("  Total deallocated bytes : "
 211         & Storage_Offset'Image (Pool.Deallocated));
 212
 213       Put_Line ("  Current Water Mark: "
 214         & Storage_Offset'Image (Pool.Allocated - Pool.Deallocated));
 215
 216       Put_Line ("  High Water Mark: "
 217         & Storage_Offset'Image (Pool.High_Water));
 218       Put_Line ("");
 219    end Print_Info;
 220
 221    ------------------
 222    -- Storage_Size --
 223    ------------------
 224
 225    function Storage_Size (Pool : Debug_Pool) return Storage_Count is
 226       pragma Warnings (Off, Pool);
 227
 228    begin
 229       return Storage_Count'Last;
 230    end Storage_Size;
 231
 232 end GNAT.Debug_Pools;