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