gcc/ada/g-dynhta.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                 G N A T . D Y N A M I C _ H T A B L E S                  --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                     Copyright (C) 2002-2016, AdaCore                     --
  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 3,  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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with Ada.Unchecked_Deallocation;
  33
  34 package body GNAT.Dynamic_HTables is
  35
  36    -------------------
  37    -- Static_HTable --
  38    -------------------
  39
  40    package body Static_HTable is
  41
  42       type Table_Type is array (Header_Num) of Elmt_Ptr;
  43
  44       type Instance_Data is record
  45          Table            : Table_Type;
  46          Iterator_Index   : Header_Num;
  47          Iterator_Ptr     : Elmt_Ptr;
  48          Iterator_Started : Boolean := False;
  49       end record;
  50
  51       function Get_Non_Null (T : Instance) return Elmt_Ptr;
  52       --  Returns Null_Ptr if Iterator_Started is False or if the Table is
  53       --  empty. Returns Iterator_Ptr if non null, or the next non null
  54       --  element in table if any.
  55
  56       ---------
  57       -- Get --
  58       ---------
  59
  60       function Get (T : Instance; K : Key) return Elmt_Ptr is
  61          Elmt : Elmt_Ptr;
  62
  63       begin
  64          if T = null then
  65             return Null_Ptr;
  66          end if;
  67
  68          Elmt := T.Table (Hash (K));
  69
  70          loop
  71             if Elmt = Null_Ptr then
  72                return Null_Ptr;
  73
  74             elsif Equal (Get_Key (Elmt), K) then
  75                return Elmt;
  76
  77             else
  78                Elmt := Next (Elmt);
  79             end if;
  80          end loop;
  81       end Get;
  82
  83       ---------------
  84       -- Get_First --
  85       ---------------
  86
  87       function Get_First (T : Instance) return Elmt_Ptr is
  88       begin
  89          if T = null then
  90             return Null_Ptr;
  91          end if;
  92
  93          T.Iterator_Started := True;
  94          T.Iterator_Index := T.Table'First;
  95          T.Iterator_Ptr := T.Table (T.Iterator_Index);
  96          return Get_Non_Null (T);
  97       end Get_First;
  98
  99       --------------
 100       -- Get_Next --
 101       --------------
 102
 103       function Get_Next (T : Instance) return Elmt_Ptr is
 104       begin
 105          if T = null or else not T.Iterator_Started then
 106             return Null_Ptr;
 107          end if;
 108
 109          T.Iterator_Ptr := Next (T.Iterator_Ptr);
 110          return Get_Non_Null (T);
 111       end Get_Next;
 112
 113       ------------------
 114       -- Get_Non_Null --
 115       ------------------
 116
 117       function Get_Non_Null (T : Instance) return Elmt_Ptr is
 118       begin
 119          if T = null then
 120             return Null_Ptr;
 121          end if;
 122
 123          while T.Iterator_Ptr = Null_Ptr  loop
 124             if T.Iterator_Index = T.Table'Last then
 125                T.Iterator_Started := False;
 126                return Null_Ptr;
 127             end if;
 128
 129             T.Iterator_Index := T.Iterator_Index + 1;
 130             T.Iterator_Ptr   := T.Table (T.Iterator_Index);
 131          end loop;
 132
 133          return T.Iterator_Ptr;
 134       end Get_Non_Null;
 135
 136       ------------
 137       -- Remove --
 138       ------------
 139
 140       procedure Remove  (T : Instance; K : Key) is
 141          Index     : constant Header_Num := Hash (K);
 142          Elmt      : Elmt_Ptr;
 143          Next_Elmt : Elmt_Ptr;
 144
 145       begin
 146          if T = null then
 147             return;
 148          end if;
 149
 150          Elmt := T.Table (Index);
 151
 152          if Elmt = Null_Ptr then
 153             return;
 154
 155          elsif Equal (Get_Key (Elmt), K) then
 156             T.Table (Index) := Next (Elmt);
 157
 158          else
 159             loop
 160                Next_Elmt := Next (Elmt);
 161
 162                if Next_Elmt = Null_Ptr then
 163                   return;
 164
 165                elsif Equal (Get_Key (Next_Elmt), K) then
 166                   Set_Next (Elmt, Next (Next_Elmt));
 167                   return;
 168
 169                else
 170                   Elmt := Next_Elmt;
 171                end if;
 172             end loop;
 173          end if;
 174       end Remove;
 175
 176       -----------
 177       -- Reset --
 178       -----------
 179
 180       procedure Reset (T : in out Instance) is
 181          procedure Free is
 182            new Ada.Unchecked_Deallocation (Instance_Data, Instance);
 183
 184       begin
 185          if T = null then
 186             return;
 187          end if;
 188
 189          for J in T.Table'Range loop
 190             T.Table (J) := Null_Ptr;
 191          end loop;
 192
 193          Free (T);
 194       end Reset;
 195
 196       ---------
 197       -- Set --
 198       ---------
 199
 200       procedure Set (T : in out Instance; E : Elmt_Ptr) is
 201          Index : Header_Num;
 202
 203       begin
 204          if T = null then
 205             T := new Instance_Data;
 206          end if;
 207
 208          Index := Hash (Get_Key (E));
 209          Set_Next (E, T.Table (Index));
 210          T.Table (Index) := E;
 211       end Set;
 212
 213    end Static_HTable;
 214
 215    -------------------
 216    -- Simple_HTable --
 217    -------------------
 218
 219    package body Simple_HTable is
 220       procedure Free is new
 221         Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr);
 222
 223       ---------
 224       -- Get --
 225       ---------
 226
 227       function Get (T : Instance; K : Key) return Element is
 228          Tmp : Elmt_Ptr;
 229
 230       begin
 231          if T = Nil then
 232             return No_Element;
 233          end if;
 234
 235          Tmp := Tab.Get (Tab.Instance (T), K);
 236
 237          if Tmp = null then
 238             return No_Element;
 239          else
 240             return Tmp.E;
 241          end if;
 242       end Get;
 243
 244       ---------------
 245       -- Get_First --
 246       ---------------
 247
 248       function Get_First (T : Instance) return Element is
 249          Tmp : constant Elmt_Ptr := Tab.Get_First (Tab.Instance (T));
 250
 251       begin
 252          if Tmp = null then
 253             return No_Element;
 254          else
 255             return Tmp.E;
 256          end if;
 257       end Get_First;
 258
 259       -------------
 260       -- Get_Key --
 261       -------------
 262
 263       function Get_Key (E : Elmt_Ptr) return Key is
 264       begin
 265          return E.K;
 266       end Get_Key;
 267
 268       --------------
 269       -- Get_Next --
 270       --------------
 271
 272       function Get_Next (T : Instance) return Element is
 273          Tmp : constant Elmt_Ptr := Tab.Get_Next (Tab.Instance (T));
 274       begin
 275          if Tmp = null then
 276             return No_Element;
 277          else
 278             return Tmp.E;
 279          end if;
 280       end Get_Next;
 281
 282       ----------
 283       -- Next --
 284       ----------
 285
 286       function Next (E : Elmt_Ptr) return Elmt_Ptr is
 287       begin
 288          return E.Next;
 289       end Next;
 290
 291       ------------
 292       -- Remove --
 293       ------------
 294
 295       procedure Remove  (T : Instance; K : Key) is
 296          Tmp : Elmt_Ptr;
 297
 298       begin
 299          Tmp := Tab.Get (Tab.Instance (T), K);
 300
 301          if Tmp /= null then
 302             Tab.Remove (Tab.Instance (T), K);
 303             Free (Tmp);
 304          end if;
 305       end Remove;
 306
 307       -----------
 308       -- Reset --
 309       -----------
 310
 311       procedure Reset (T : in out Instance) is
 312          E1, E2 : Elmt_Ptr;
 313
 314       begin
 315          E1 := Tab.Get_First (Tab.Instance (T));
 316          while E1 /= null loop
 317             E2 := Tab.Get_Next (Tab.Instance (T));
 318             Free (E1);
 319             E1 := E2;
 320          end loop;
 321
 322          Tab.Reset (Tab.Instance (T));
 323       end Reset;
 324
 325       ---------
 326       -- Set --
 327       ---------
 328
 329       procedure Set (T : in out Instance; K : Key; E : Element) is
 330          Tmp : constant Elmt_Ptr := Tab.Get (Tab.Instance (T), K);
 331       begin
 332          if Tmp = null then
 333             Tab.Set (Tab.Instance (T), new Element_Wrapper'(K, E, null));
 334          else
 335             Tmp.E := E;
 336          end if;
 337       end Set;
 338
 339       --------------
 340       -- Set_Next --
 341       --------------
 342
 343       procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
 344       begin
 345          E.Next := Next;
 346       end Set_Next;
 347
 348    end Simple_HTable;
 349
 350    ------------------------
 351    -- Load_Factor_HTable --
 352    ------------------------
 353
 354    package body Load_Factor_HTable is
 355
 356       Min_Size_Increase : constant := 5;
 357       --  The minimum increase expressed as number of buckets. This value is
 358       --  used to determine the new size of small tables and/or small growth
 359       --  percentages.
 360
 361       procedure Attach
 362         (Elmt  : not null Element_Ptr;
 363          Chain : not null Element_Ptr);
 364       --  Prepend an element to a bucket chain. Elmt is inserted after the
 365       --  dummy head of Chain.
 366
 367       function Create_Buckets (Size : Positive) return Buckets_Array_Ptr;
 368       --  Allocate and initialize a new set of buckets. The buckets are created
 369       --  in the range Range_Type'First .. Range_Type'First + Size - 1.
 370
 371       procedure Detach (Elmt : not null Element_Ptr);
 372       --  Remove an element from an arbitrary bucket chain
 373
 374       function Find
 375         (Key   : Key_Type;
 376          Chain : not null Element_Ptr) return Element_Ptr;
 377       --  Try to locate the element which contains a particular key within a
 378       --  bucket chain. If no such element exists, return No_Element.
 379
 380       procedure Free is
 381         new Ada.Unchecked_Deallocation (Buckets_Array, Buckets_Array_Ptr);
 382
 383       procedure Free is
 384         new Ada.Unchecked_Deallocation (Element, Element_Ptr);
 385
 386       function Is_Empty_Chain (Chain : not null Element_Ptr) return Boolean;
 387       --  Determine whether a bucket chain contains only one element, namely
 388       --  the dummy head.
 389
 390       ------------
 391       -- Attach --
 392       ------------
 393
 394       procedure Attach
 395         (Elmt  : not null Element_Ptr;
 396          Chain : not null Element_Ptr)
 397       is
 398       begin
 399          Chain.Next.Prev := Elmt;
 400          Elmt.Next  := Chain.Next;
 401          Chain.Next := Elmt;
 402          Elmt.Prev  := Chain;
 403       end Attach;
 404
 405       --------------------
 406       -- Create_Buckets --
 407       --------------------
 408
 409       function Create_Buckets (Size : Positive) return Buckets_Array_Ptr is
 410          Low_Bound : constant Range_Type := Range_Type'First;
 411          Buckets   : Buckets_Array_Ptr;
 412
 413       begin
 414          Buckets :=
 415            new Buckets_Array (Low_Bound .. Low_Bound + Range_Type (Size) - 1);
 416
 417          --  Ensure that the dummy head of each bucket chain points to itself
 418          --  in both directions.
 419
 420          for Index in Buckets'Range loop
 421             declare
 422                Bucket : Element renames Buckets (Index);
 423
 424             begin
 425                Bucket.Prev := Bucket'Unchecked_Access;
 426                Bucket.Next := Bucket'Unchecked_Access;
 427             end;
 428          end loop;
 429
 430          return Buckets;
 431       end Create_Buckets;
 432
 433       ------------------
 434       -- Current_Size --
 435       ------------------
 436
 437       function Current_Size (T : Table) return Positive is
 438       begin
 439          --  The table should have been properly initialized during object
 440          --  elaboration.
 441
 442          if T.Buckets = null then
 443             raise Program_Error;
 444
 445          --  The size of the table is determined by the number of buckets
 446
 447          else
 448             return T.Buckets'Length;
 449          end if;
 450       end Current_Size;
 451
 452       ------------
 453       -- Detach --
 454       ------------
 455
 456       procedure Detach (Elmt : not null Element_Ptr) is
 457       begin
 458          if Elmt.Prev /= null and Elmt.Next /= null then
 459             Elmt.Prev.Next := Elmt.Next;
 460             Elmt.Next.Prev := Elmt.Prev;
 461             Elmt.Prev := null;
 462             Elmt.Next := null;
 463          end if;
 464       end Detach;
 465
 466       --------------
 467       -- Finalize --
 468       --------------
 469
 470       procedure Finalize (T : in out Table) is
 471          Bucket : Element_Ptr;
 472          Elmt   : Element_Ptr;
 473
 474       begin
 475          --  Inspect the buckets and deallocate bucket chains
 476
 477          for Index in T.Buckets'Range loop
 478             Bucket := T.Buckets (Index)'Unchecked_Access;
 479
 480             --  The current bucket chain contains an element other than the
 481             --  dummy head.
 482
 483             while not Is_Empty_Chain (Bucket) loop
 484
 485                --  Skip the dummy head, remove and deallocate the element
 486
 487                Elmt := Bucket.Next;
 488                Detach (Elmt);
 489                Free   (Elmt);
 490             end loop;
 491          end loop;
 492
 493          --  Deallocate the buckets
 494
 495          Free (T.Buckets);
 496       end Finalize;
 497
 498       ----------
 499       -- Find --
 500       ----------
 501
 502       function Find
 503         (Key   : Key_Type;
 504          Chain : not null Element_Ptr) return Element_Ptr
 505       is
 506          Elmt : Element_Ptr;
 507
 508       begin
 509          --  Skip the dummy head, inspect the bucket chain for an element whose
 510          --  key matches the requested key. Since each bucket chain is circular
 511          --  the search must stop once the dummy head is encountered.
 512
 513          Elmt := Chain.Next;
 514          while Elmt /= Chain loop
 515             if Equal (Elmt.Key, Key) then
 516                return Elmt;
 517             end if;
 518
 519             Elmt := Elmt.Next;
 520          end loop;
 521
 522          return No_Element;
 523       end Find;
 524
 525       ---------
 526       -- Get --
 527       ---------
 528
 529       function Get (T : Table; Key : Key_Type) return Value_Type is
 530          Bucket : Element_Ptr;
 531          Elmt   : Element_Ptr;
 532
 533       begin
 534          --  Obtain the bucket chain where the (key, value) pair should reside
 535          --  by calculating the proper hash location.
 536
 537          Bucket := T.Buckets (Hash (Key, Current_Size (T)))'Unchecked_Access;
 538
 539          --  Try to find an element whose key matches the requested key
 540
 541          Elmt := Find (Key, Bucket);
 542
 543          --  The hash table does not contain a matching (key, value) pair
 544
 545          if Elmt = No_Element then
 546             return No_Value;
 547          else
 548             return Elmt.Val;
 549          end if;
 550       end Get;
 551
 552       ----------------
 553       -- Initialize --
 554       ----------------
 555
 556       procedure Initialize (T : in out Table) is
 557       begin
 558          pragma Assert (T.Buckets = null);
 559
 560          T.Buckets       := Create_Buckets (Initial_Size);
 561          T.Element_Count := 0;
 562       end Initialize;
 563
 564       --------------------
 565       -- Is_Empty_Chain --
 566       --------------------
 567
 568       function Is_Empty_Chain (Chain : not null Element_Ptr) return Boolean is
 569       begin
 570          return Chain.Next = Chain and Chain.Prev = Chain;
 571       end Is_Empty_Chain;
 572
 573       ------------
 574       -- Remove --
 575       ------------
 576
 577       procedure Remove (T : in out Table; Key : Key_Type) is
 578          Bucket : Element_Ptr;
 579          Elmt   : Element_Ptr;
 580
 581       begin
 582          --  Obtain the bucket chain where the (key, value) pair should reside
 583          --  by calculating the proper hash location.
 584
 585          Bucket := T.Buckets (Hash (Key, Current_Size (T)))'Unchecked_Access;
 586
 587          --  Try to find an element whose key matches the requested key
 588
 589          Elmt := Find (Key, Bucket);
 590
 591          --  Remove and deallocate the (key, value) pair
 592
 593          if Elmt /= No_Element then
 594             Detach (Elmt);
 595             Free   (Elmt);
 596          end if;
 597       end Remove;
 598
 599       ---------
 600       -- Set --
 601       ---------
 602
 603       procedure Set
 604         (T   : in out Table;
 605          Key : Key_Type;
 606          Val : Value_Type)
 607       is
 608          Curr_Size : constant Positive := Current_Size (T);
 609
 610          procedure Grow;
 611          --  Grow the table to a new size according to the desired percentage
 612          --  and relocate all existing elements to the new buckets.
 613
 614          ----------
 615          -- Grow --
 616          ----------
 617
 618          procedure Grow is
 619             Buckets     : Buckets_Array_Ptr;
 620             Elmt        : Element_Ptr;
 621             Hash_Loc    : Range_Type;
 622             Old_Bucket  : Element_Ptr;
 623             Old_Buckets : Buckets_Array_Ptr := T.Buckets;
 624             Size        : Positive;
 625
 626          begin
 627             --  Calculate the new size and allocate a new set of buckets. Note
 628             --  that a table with a small size or a small growth percentage may
 629             --  not always grow (for example, 10 buckets and 3% increase). In
 630             --  that case, enforce a minimum increase.
 631
 632             Size :=
 633               Positive'Max (Curr_Size * ((100 + Growth_Percentage) / 100),
 634                             Min_Size_Increase);
 635             Buckets := Create_Buckets (Size);
 636
 637             --  Inspect the old buckets and transfer all elements by rehashing
 638             --  all (key, value) pairs in the new buckets.
 639
 640             for Index in Old_Buckets'Range loop
 641                Old_Bucket := Old_Buckets (Index)'Unchecked_Access;
 642
 643                --  The current bucket chain contains an element other than the
 644                --  dummy head.
 645
 646                while not Is_Empty_Chain (Old_Bucket) loop
 647
 648                   --  Skip the dummy head and find the new hash location
 649
 650                   Elmt     := Old_Bucket.Next;
 651                   Hash_Loc := Hash (Elmt.Key, Size);
 652
 653                   --  Remove the element from the old buckets and insert it
 654                   --  into the new buckets. Note that there is no need to check
 655                   --  for duplicates because the hash table did not have any to
 656                   --  begin with.
 657
 658                   Detach (Elmt);
 659                   Attach
 660                     (Elmt  => Elmt,
 661                      Chain => Buckets (Hash_Loc)'Unchecked_Access);
 662                end loop;
 663             end loop;
 664
 665             --  Associate the new buckets with the table and reclaim the
 666             --  storage occupied by the old buckets.
 667
 668             T.Buckets := Buckets;
 669
 670             Free (Old_Buckets);
 671          end Grow;
 672
 673          --  Local variables
 674
 675          subtype LLF is Long_Long_Float;
 676
 677          Count    : Natural renames T.Element_Count;
 678          Bucket   : Element_Ptr;
 679          Hash_Loc : Range_Type;
 680
 681       --  Start of processing for Set
 682
 683       begin
 684          --  Find the bucket where the (key, value) pair should be inserted by
 685          --  computing the proper hash location.
 686
 687          Hash_Loc := Hash (Key, Curr_Size);
 688          Bucket   := T.Buckets (Hash_Loc)'Unchecked_Access;
 689
 690          --  Ensure that the key is not already present in the bucket in order
 691          --  to avoid duplicates.
 692
 693          if Find (Key, Bucket) = No_Element then
 694             Attach
 695               (Elmt  => new Element'(Key, Val, null, null),
 696                Chain => Bucket);
 697             Count := Count + 1;
 698
 699             --  Multiple insertions may cause long bucket chains and decrease
 700             --  the performance of basic operations. If this is the case, grow
 701             --  the table and rehash all existing elements.
 702
 703             if (LLF (Count) / LLF (Curr_Size)) > LLF (Load_Factor) then
 704                Grow;
 705             end if;
 706          end if;
 707       end Set;
 708    end Load_Factor_HTable;
 709
 710 end GNAT.Dynamic_HTables;