path: root/gcc/ada/g-dynhta.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--                 G N A T . D Y N A M I C _ H T A B L E S                  --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2002-2016, AdaCore                     --
--                                                                          --
-- 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- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Unchecked_Deallocation;

package body GNAT.Dynamic_HTables is

   -------------------
   -- Static_HTable --
   -------------------

   package body Static_HTable is

      type Table_Type is array (Header_Num) of Elmt_Ptr;

      type Instance_Data is record
         Table            : Table_Type;
         Iterator_Index   : Header_Num;
         Iterator_Ptr     : Elmt_Ptr;
         Iterator_Started : Boolean := False;
      end record;

      function Get_Non_Null (T : Instance) return Elmt_Ptr;
      --  Returns Null_Ptr if Iterator_Started is False or if the Table is
      --  empty. Returns Iterator_Ptr if non null, or the next non null
      --  element in table if any.

      ---------
      -- Get --
      ---------

      function Get (T : Instance; K : Key) return Elmt_Ptr is
         Elmt : Elmt_Ptr;

      begin
         if T = null then
            return Null_Ptr;
         end if;

         Elmt := T.Table (Hash (K));

         loop
            if Elmt = Null_Ptr then
               return Null_Ptr;

            elsif Equal (Get_Key (Elmt), K) then
               return Elmt;

            else
               Elmt := Next (Elmt);
            end if;
         end loop;
      end Get;

      ---------------
      -- Get_First --
      ---------------

      function Get_First (T : Instance) return Elmt_Ptr is
      begin
         if T = null then
            return Null_Ptr;
         end if;

         T.Iterator_Started := True;
         T.Iterator_Index := T.Table'First;
         T.Iterator_Ptr := T.Table (T.Iterator_Index);
         return Get_Non_Null (T);
      end Get_First;

      --------------
      -- Get_Next --
      --------------

      function Get_Next (T : Instance) return Elmt_Ptr is
      begin
         if T = null or else not T.Iterator_Started then
            return Null_Ptr;
         end if;

         T.Iterator_Ptr := Next (T.Iterator_Ptr);
         return Get_Non_Null (T);
      end Get_Next;

      ------------------
      -- Get_Non_Null --
      ------------------

      function Get_Non_Null (T : Instance) return Elmt_Ptr is
      begin
         if T = null then
            return Null_Ptr;
         end if;

         while T.Iterator_Ptr = Null_Ptr  loop
            if T.Iterator_Index = T.Table'Last then
               T.Iterator_Started := False;
               return Null_Ptr;
            end if;

            T.Iterator_Index := T.Iterator_Index + 1;
            T.Iterator_Ptr   := T.Table (T.Iterator_Index);
         end loop;

         return T.Iterator_Ptr;
      end Get_Non_Null;

      ------------
      -- Remove --
      ------------

      procedure Remove  (T : Instance; K : Key) is
         Index     : constant Header_Num := Hash (K);
         Elmt      : Elmt_Ptr;
         Next_Elmt : Elmt_Ptr;

      begin
         if T = null then
            return;
         end if;

         Elmt := T.Table (Index);

         if Elmt = Null_Ptr then
            return;

         elsif Equal (Get_Key (Elmt), K) then
            T.Table (Index) := Next (Elmt);

         else
            loop
               Next_Elmt := Next (Elmt);

               if Next_Elmt = Null_Ptr then
                  return;

               elsif Equal (Get_Key (Next_Elmt), K) then
                  Set_Next (Elmt, Next (Next_Elmt));
                  return;

               else
                  Elmt := Next_Elmt;
               end if;
            end loop;
         end if;
      end Remove;

      -----------
      -- Reset --
      -----------

      procedure Reset (T : in out Instance) is
         procedure Free is
           new Ada.Unchecked_Deallocation (Instance_Data, Instance);

      begin
         if T = null then
            return;
         end if;

         for J in T.Table'Range loop
            T.Table (J) := Null_Ptr;
         end loop;

         Free (T);
      end Reset;

      ---------
      -- Set --
      ---------

      procedure Set (T : in out Instance; E : Elmt_Ptr) is
         Index : Header_Num;

      begin
         if T = null then
            T := new Instance_Data;
         end if;

         Index := Hash (Get_Key (E));
         Set_Next (E, T.Table (Index));
         T.Table (Index) := E;
      end Set;

   end Static_HTable;

   -------------------
   -- Simple_HTable --
   -------------------

   package body Simple_HTable is
      procedure Free is new
        Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr);

      ---------
      -- Get --
      ---------

      function Get (T : Instance; K : Key) return Element is
         Tmp : Elmt_Ptr;

      begin
         if T = Nil then
            return No_Element;
         end if;

         Tmp := Tab.Get (Tab.Instance (T), K);

         if Tmp = null then
            return No_Element;
         else
            return Tmp.E;
         end if;
      end Get;

      ---------------
      -- Get_First --
      ---------------

      function Get_First (T : Instance) return Element is
         Tmp : constant Elmt_Ptr := Tab.Get_First (Tab.Instance (T));

      begin
         if Tmp = null then
            return No_Element;
         else
            return Tmp.E;
         end if;
      end Get_First;

      -------------
      -- Get_Key --
      -------------

      function Get_Key (E : Elmt_Ptr) return Key is
      begin
         return E.K;
      end Get_Key;

      --------------
      -- Get_Next --
      --------------

      function Get_Next (T : Instance) return Element is
         Tmp : constant Elmt_Ptr := Tab.Get_Next (Tab.Instance (T));
      begin
         if Tmp = null then
            return No_Element;
         else
            return Tmp.E;
         end if;
      end Get_Next;

      ----------
      -- Next --
      ----------

      function Next (E : Elmt_Ptr) return Elmt_Ptr is
      begin
         return E.Next;
      end Next;

      ------------
      -- Remove --
      ------------

      procedure Remove  (T : Instance; K : Key) is
         Tmp : Elmt_Ptr;

      begin
         Tmp := Tab.Get (Tab.Instance (T), K);

         if Tmp /= null then
            Tab.Remove (Tab.Instance (T), K);
            Free (Tmp);
         end if;
      end Remove;

      -----------
      -- Reset --
      -----------

      procedure Reset (T : in out Instance) is
         E1, E2 : Elmt_Ptr;

      begin
         E1 := Tab.Get_First (Tab.Instance (T));
         while E1 /= null loop
            E2 := Tab.Get_Next (Tab.Instance (T));
            Free (E1);
            E1 := E2;
         end loop;

         Tab.Reset (Tab.Instance (T));
      end Reset;

      ---------
      -- Set --
      ---------

      procedure Set (T : in out Instance; K : Key; E : Element) is
         Tmp : constant Elmt_Ptr := Tab.Get (Tab.Instance (T), K);
      begin
         if Tmp = null then
            Tab.Set (Tab.Instance (T), new Element_Wrapper'(K, E, null));
         else
            Tmp.E := E;
         end if;
      end Set;

      --------------
      -- Set_Next --
      --------------

      procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
      begin
         E.Next := Next;
      end Set_Next;

   end Simple_HTable;

   ------------------------
   -- Load_Factor_HTable --
   ------------------------

   package body Load_Factor_HTable is

      Min_Size_Increase : constant := 5;
      --  The minimum increase expressed as number of buckets. This value is
      --  used to determine the new size of small tables and/or small growth
      --  percentages.

      procedure Attach
        (Elmt  : not null Element_Ptr;
         Chain : not null Element_Ptr);
      --  Prepend an element to a bucket chain. Elmt is inserted after the
      --  dummy head of Chain.

      function Create_Buckets (Size : Positive) return Buckets_Array_Ptr;
      --  Allocate and initialize a new set of buckets. The buckets are created
      --  in the range Range_Type'First .. Range_Type'First + Size - 1.

      procedure Detach (Elmt : not null Element_Ptr);
      --  Remove an element from an arbitrary bucket chain

      function Find
        (Key   : Key_Type;
         Chain : not null Element_Ptr) return Element_Ptr;
      --  Try to locate the element which contains a particular key within a
      --  bucket chain. If no such element exists, return No_Element.

      procedure Free is
        new Ada.Unchecked_Deallocation (Buckets_Array, Buckets_Array_Ptr);

      procedure Free is
        new Ada.Unchecked_Deallocation (Element, Element_Ptr);

      function Is_Empty_Chain (Chain : not null Element_Ptr) return Boolean;
      --  Determine whether a bucket chain contains only one element, namely
      --  the dummy head.

      ------------
      -- Attach --
      ------------

      procedure Attach
        (Elmt  : not null Element_Ptr;
         Chain : not null Element_Ptr)
      is
      begin
         Chain.Next.Prev := Elmt;
         Elmt.Next  := Chain.Next;
         Chain.Next := Elmt;
         Elmt.Prev  := Chain;
      end Attach;

      --------------------
      -- Create_Buckets --
      --------------------

      function Create_Buckets (Size : Positive) return Buckets_Array_Ptr is
         Low_Bound : constant Range_Type := Range_Type'First;
         Buckets   : Buckets_Array_Ptr;

      begin
         Buckets :=
           new Buckets_Array (Low_Bound .. Low_Bound + Range_Type (Size) - 1);

         --  Ensure that the dummy head of each bucket chain points to itself
         --  in both directions.

         for Index in Buckets'Range loop
            declare
               Bucket : Element renames Buckets (Index);

            begin
               Bucket.Prev := Bucket'Unchecked_Access;
               Bucket.Next := Bucket'Unchecked_Access;
            end;
         end loop;

         return Buckets;
      end Create_Buckets;

      ------------------
      -- Current_Size --
      ------------------

      function Current_Size (T : Table) return Positive is
      begin
         --  The table should have been properly initialized during object
         --  elaboration.

         if T.Buckets = null then
            raise Program_Error;

         --  The size of the table is determined by the number of buckets

         else
            return T.Buckets'Length;
         end if;
      end Current_Size;

      ------------
      -- Detach --
      ------------

      procedure Detach (Elmt : not null Element_Ptr) is
      begin
         if Elmt.Prev /= null and Elmt.Next /= null then
            Elmt.Prev.Next := Elmt.Next;
            Elmt.Next.Prev := Elmt.Prev;
            Elmt.Prev := null;
            Elmt.Next := null;
         end if;
      end Detach;

      --------------
      -- Finalize --
      --------------

      procedure Finalize (T : in out Table) is
         Bucket : Element_Ptr;
         Elmt   : Element_Ptr;

      begin
         --  Inspect the buckets and deallocate bucket chains

         for Index in T.Buckets'Range loop
            Bucket := T.Buckets (Index)'Unchecked_Access;

            --  The current bucket chain contains an element other than the
            --  dummy head.

            while not Is_Empty_Chain (Bucket) loop

               --  Skip the dummy head, remove and deallocate the element

               Elmt := Bucket.Next;
               Detach (Elmt);
               Free   (Elmt);
            end loop;
         end loop;

         --  Deallocate the buckets

         Free (T.Buckets);
      end Finalize;

      ----------
      -- Find --
      ----------

      function Find
        (Key   : Key_Type;
         Chain : not null Element_Ptr) return Element_Ptr
      is
         Elmt : Element_Ptr;

      begin
         --  Skip the dummy head, inspect the bucket chain for an element whose
         --  key matches the requested key. Since each bucket chain is circular
         --  the search must stop once the dummy head is encountered.

         Elmt := Chain.Next;
         while Elmt /= Chain loop
            if Equal (Elmt.Key, Key) then
               return Elmt;
            end if;

            Elmt := Elmt.Next;
         end loop;

         return No_Element;
      end Find;

      ---------
      -- Get --
      ---------

      function Get (T : Table; Key : Key_Type) return Value_Type is
         Bucket : Element_Ptr;
         Elmt   : Element_Ptr;

      begin
         --  Obtain the bucket chain where the (key, value) pair should reside
         --  by calculating the proper hash location.

         Bucket := T.Buckets (Hash (Key, Current_Size (T)))'Unchecked_Access;

         --  Try to find an element whose key matches the requested key

         Elmt := Find (Key, Bucket);

         --  The hash table does not contain a matching (key, value) pair

         if Elmt = No_Element then
            return No_Value;
         else
            return Elmt.Val;
         end if;
      end Get;

      ----------------
      -- Initialize --
      ----------------

      procedure Initialize (T : in out Table) is
      begin
         pragma Assert (T.Buckets = null);

         T.Buckets       := Create_Buckets (Initial_Size);
         T.Element_Count := 0;
      end Initialize;

      --------------------
      -- Is_Empty_Chain --
      --------------------

      function Is_Empty_Chain (Chain : not null Element_Ptr) return Boolean is
      begin
         return Chain.Next = Chain and Chain.Prev = Chain;
      end Is_Empty_Chain;

      ------------
      -- Remove --
      ------------

      procedure Remove (T : in out Table; Key : Key_Type) is
         Bucket : Element_Ptr;
         Elmt   : Element_Ptr;

      begin
         --  Obtain the bucket chain where the (key, value) pair should reside
         --  by calculating the proper hash location.

         Bucket := T.Buckets (Hash (Key, Current_Size (T)))'Unchecked_Access;

         --  Try to find an element whose key matches the requested key

         Elmt := Find (Key, Bucket);

         --  Remove and deallocate the (key, value) pair

         if Elmt /= No_Element then
            Detach (Elmt);
            Free   (Elmt);
         end if;
      end Remove;

      ---------
      -- Set --
      ---------

      procedure Set
        (T   : in out Table;
         Key : Key_Type;
         Val : Value_Type)
      is
         Curr_Size : constant Positive := Current_Size (T);

         procedure Grow;
         --  Grow the table to a new size according to the desired percentage
         --  and relocate all existing elements to the new buckets.

         ----------
         -- Grow --
         ----------

         procedure Grow is
            Buckets     : Buckets_Array_Ptr;
            Elmt        : Element_Ptr;
            Hash_Loc    : Range_Type;
            Old_Bucket  : Element_Ptr;
            Old_Buckets : Buckets_Array_Ptr := T.Buckets;
            Size        : Positive;

         begin
            --  Calculate the new size and allocate a new set of buckets. Note
            --  that a table with a small size or a small growth percentage may
            --  not always grow (for example, 10 buckets and 3% increase). In
            --  that case, enforce a minimum increase.

            Size :=
              Positive'Max (Curr_Size * ((100 + Growth_Percentage) / 100),
                            Min_Size_Increase);
            Buckets := Create_Buckets (Size);

            --  Inspect the old buckets and transfer all elements by rehashing
            --  all (key, value) pairs in the new buckets.

            for Index in Old_Buckets'Range loop
               Old_Bucket := Old_Buckets (Index)'Unchecked_Access;

               --  The current bucket chain contains an element other than the
               --  dummy head.

               while not Is_Empty_Chain (Old_Bucket) loop

                  --  Skip the dummy head and find the new hash location

                  Elmt     := Old_Bucket.Next;
                  Hash_Loc := Hash (Elmt.Key, Size);

                  --  Remove the element from the old buckets and insert it
                  --  into the new buckets. Note that there is no need to check
                  --  for duplicates because the hash table did not have any to
                  --  begin with.

                  Detach (Elmt);
                  Attach
                    (Elmt  => Elmt,
                     Chain => Buckets (Hash_Loc)'Unchecked_Access);
               end loop;
            end loop;

            --  Associate the new buckets with the table and reclaim the
            --  storage occupied by the old buckets.

            T.Buckets := Buckets;

            Free (Old_Buckets);
         end Grow;

         --  Local variables

         subtype LLF is Long_Long_Float;

         Count    : Natural renames T.Element_Count;
         Bucket   : Element_Ptr;
         Hash_Loc : Range_Type;

      --  Start of processing for Set

      begin
         --  Find the bucket where the (key, value) pair should be inserted by
         --  computing the proper hash location.

         Hash_Loc := Hash (Key, Curr_Size);
         Bucket   := T.Buckets (Hash_Loc)'Unchecked_Access;

         --  Ensure that the key is not already present in the bucket in order
         --  to avoid duplicates.

         if Find (Key, Bucket) = No_Element then
            Attach
              (Elmt  => new Element'(Key, Val, null, null),
               Chain => Bucket);
            Count := Count + 1;

            --  Multiple insertions may cause long bucket chains and decrease
            --  the performance of basic operations. If this is the case, grow
            --  the table and rehash all existing elements.

            if (LLF (Count) / LLF (Curr_Size)) > LLF (Load_Factor) then
               Grow;
            end if;
         end if;
      end Set;
   end Load_Factor_HTable;

end GNAT.Dynamic_HTables;