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