From cc9b1e1ca0e9c28d8a8704abb9faa1ea3b76d676 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 30 Oct 2014 12:53:39 +0100 Subject: [PATCH] [multiple changes] 2014-10-30 Ed Schonberg * exp_ch3.adb (Expand_N_Object_Declaration): Code cleanup. 2014-10-30 Ed Schonberg * sem_ch5.adb (Analyze_Iterator_Specification): If a subtype indication is provided, check properly that it covers the element type of of the container type. 2014-10-30 Hristian Kirtchev * g-dynhta.ads, g-dynhta.adb: Add the implementation of a load facto -based hash table. From-SVN: r216926 --- gcc/ada/ChangeLog | 15 ++ gcc/ada/exp_ch3.adb | 26 +-- gcc/ada/g-dynhta.adb | 366 ++++++++++++++++++++++++++++++++++++++++++- gcc/ada/g-dynhta.ads | 132 ++++++++++++++-- gcc/ada/sem_ch5.adb | 4 +- 5 files changed, 517 insertions(+), 26 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1826cea7121..4a87fef7a2e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,18 @@ +2014-10-30 Ed Schonberg + + * exp_ch3.adb (Expand_N_Object_Declaration): Code cleanup. + +2014-10-30 Ed Schonberg + + * sem_ch5.adb (Analyze_Iterator_Specification): If a subtype + indication is provided, check properly that it covers the element + type of of the container type. + +2014-10-30 Hristian Kirtchev + + * g-dynhta.ads, g-dynhta.adb: Add the implementation of a load facto + -based hash table. + 2014-10-30 Ed Schonberg * exp_util.ads, exp_util.adb (Following_Address_Clause): Modify diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 5d544b89e14..8df5a503ed4 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -5834,7 +5834,8 @@ package body Exp_Ch3 is or else Nkind (Expression (Expr)) /= N_Aggregate) then declare - Full_Typ : constant Entity_Id := Underlying_Type (Typ); + Full_Typ : constant Entity_Id := Underlying_Type (Typ); + Tag_Assign : Node_Id; begin -- The re-assignment of the tag has to be done even if the @@ -5849,6 +5850,16 @@ package body Exp_Ch3 is Loc)); Set_Assignment_OK (New_Ref); + Tag_Assign := + Make_Assignment_Statement (Loc, + Name => New_Ref, + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Occurrence_Of + (Node + (First_Elmt (Access_Disp_Table (Full_Typ))), + Loc))); + -- Tag initialization cannot be done before object is -- frozen. If an address clause follows, make sure freeze -- node exists, and insert it and the tag assignment after @@ -5856,20 +5867,9 @@ package body Exp_Ch3 is if Present (Following_Address_Clause (N)) then Init_After := Following_Address_Clause (N); - Ensure_Freeze_Node (Def_Id); end if; - Insert_Actions_After (Init_After, - New_List ( - Freeze_Node (Def_Id), - Make_Assignment_Statement (Loc, - Name => New_Ref, - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Occurrence_Of - (Node - (First_Elmt (Access_Disp_Table (Full_Typ))), - Loc))))); + Insert_Action_After (Init_After, Tag_Assign); end; -- Handle C++ constructor calls. Note that we do not check that diff --git a/gcc/ada/g-dynhta.adb b/gcc/ada/g-dynhta.adb index f8ac29dbb68..9d3424c54fc 100644 --- a/gcc/ada/g-dynhta.adb +++ b/gcc/ada/g-dynhta.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2010, AdaCore -- +-- Copyright (C) 2002-2014, 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- -- @@ -29,6 +29,8 @@ -- -- ------------------------------------------------------------------------------ +with Ada.Unchecked_Deallocation; + package body GNAT.Dynamic_HTables is ------------------- @@ -215,6 +217,8 @@ package body GNAT.Dynamic_HTables is ------------------- package body Simple_HTable is + procedure Free is new + Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr); --------- -- Get -- @@ -343,4 +347,364 @@ package body GNAT.Dynamic_HTables is 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 curcular + -- 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; diff --git a/gcc/ada/g-dynhta.ads b/gcc/ada/g-dynhta.ads index e731ed359b3..b5670b3120a 100644 --- a/gcc/ada/g-dynhta.ads +++ b/gcc/ada/g-dynhta.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2013, AdaCore -- +-- Copyright (C) 1995-2014, 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- -- @@ -31,11 +31,13 @@ -- Hash table searching routines --- This package contains two separate packages. The Simple_HTable package --- provides a very simple abstraction that associates one element to one --- key value and takes care of all allocations automatically using the heap. --- The Static_HTable package provides a more complex interface that allows --- complete control over allocation. +-- This package contains three separate packages. The Simple_HTable package +-- provides a very simple abstraction that associates one element to one key +-- value and takes care of all allocations automatically using the heap. The +-- Static_HTable package provides a more complex interface that allows full +-- control over allocation. The Load_Factor_HTable package provides a more +-- complex abstraction where collisions are resolved by chaining, and the +-- table grows by a percentage after the load factor has been exceeded. -- This package provides a facility similar to that of GNAT.HTable, except -- that this package declares types that can be used to define dynamic @@ -46,7 +48,8 @@ -- GNAT.HTable to keep as much coherency as possible between these two -- related units. -with Ada.Unchecked_Deallocation; +private with Ada.Finalization; + package GNAT.Dynamic_HTables is ------------------- @@ -210,9 +213,6 @@ package GNAT.Dynamic_HTables is Next : Elmt_Ptr; end record; - procedure Free is new - Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr); - procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); function Next (E : Elmt_Ptr) return Elmt_Ptr; function Get_Key (E : Elmt_Ptr) return Key; @@ -234,4 +234,116 @@ package GNAT.Dynamic_HTables is end Simple_HTable; + ------------------------ + -- Load_Factor_HTable -- + ------------------------ + + -- A simple hash table abstraction capable of growing once a treshold has + -- been exceeded. Collisions are resolved by chaining elements onto lists + -- hanging from individual buckets. This implementation does not make any + -- effort in minimizing the number of necessary rehashes once the table has + -- been expanded, hence the term "simple". + + -- WARNING: This hash table implementation utilizes dynamic allocation. + -- Storage reclamation is performed by the hash table. + + -- WARNING: This hash table implementation is not thread-safe. To achieve + -- proper concurrency and synchronization, wrap an instance of a table in + -- a protected object. + + generic + type Range_Type is range <>; + -- The underlying range of the hash table. Note that this type must be + -- large enough to accomodate multiple expansions of the table. + + type Key_Type is private; + type Value_Type is private; + -- The types of the (key, value) pair stored in the hash table + + No_Value : Value_Type; + -- A predefined value denoting a non-existent value + + Initial_Size : Positive; + -- The starting size of the hash table. The hash table must contain at + -- least one bucket. + + Growth_Percentage : Positive; + -- The amount of increase expressed as a percentage. The hash table must + -- grow by at least 1%. To illustrate, a value of 100 will increase the + -- table by 100% effectively doubling its size. + + Load_Factor : Float; + -- The ratio of the elements stored within the hash table divided by the + -- current size of the table. This value acts as the growth treshold. If + -- exceeded, the hash table is expanded by Growth_Percentage. + + with function Equal + (Left : Key_Type; + Right : Key_Type) return Boolean; + + with function Hash + (Key : Key_Type; + Size : Positive) return Range_Type; + -- Parameter Size denotes the current size of the hash table + + package Load_Factor_HTable is + type Table is tagged limited private; + + function Current_Size (T : Table) return Positive; + -- Obtain the current size of the table + + function Get (T : Table; Key : Key_Type) return Value_Type; + -- Obtain the value associated with a key. This routne returns No_Value + -- if the key is not present in the hash table. + + procedure Remove (T : in out Table; Key : Key_Type); + -- Remove the value associated with the given key. This routine has no + -- effect if the key is not present in the hash table. + + procedure Set + (T : in out Table; + Key : Key_Type; + Val : Value_Type); + -- Associate a value with a given key. This routine has no effect if the + -- the (key, value) pair is already present in the hash table. Note that + -- this action may cause the table to grow. + + private + -- The following types model a bucket chain. Note that the key is also + -- stored for rehashing purposes. + + type Element; + type Element_Ptr is access all Element; + type Element is record + Key : Key_Type; + Val : Value_Type; + Prev : Element_Ptr := null; + Next : Element_Ptr := null; + end record; + + No_Element : constant Element_Ptr := null; + + -- The following types model the buckets of the hash table. Each bucket + -- has a dummy head to facilitate insertion and deletion of elements. + + type Buckets_Array is array (Range_Type range <>) of aliased Element; + type Buckets_Array_Ptr is access all Buckets_Array; + + type Table is new Ada.Finalization.Limited_Controlled with record + Buckets : Buckets_Array_Ptr := null; + + Element_Count : Natural := 0; + -- The number of (key, value) pairs stored in the hash table + end record; + + procedure Finalize (T : in out Table); + -- Destroy the contents of a hash table by reclaiming all storage used + -- by buckets and their respective chains. + + procedure Initialize (T : in out Table); + -- Create a hash table with buckets within the range Range_Type'First .. + -- Range_Type'First + Initial_Size - 1. + + end Load_Factor_HTable; + end GNAT.Dynamic_HTables; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 925db4a780c..245464a6706 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2009,10 +2009,10 @@ package body Sem_Ch5 is Set_Etype (Def_Id, Entity (Element)); -- If subtype indication was given, verify that it - -- matches element type of container. + -- covers the element type of the container. if Present (Subt) - and then Bas /= Base_Type (Etype (Def_Id)) + and then not Covers (Bas, Etype (Def_Id)) then Error_Msg_N ("subtype indication does not match element type", -- 2.30.2