From: Piotr Trojanek Date: Fri, 8 Jan 2021 18:53:41 +0000 (+0100) Subject: [Ada] Speed up enumeration'Value with perfect hash function X-Git-Tag: basepoints/gcc-13~7829 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=c11207d345f8d678d440a3ff0f335b2ed25513e7;p=thirdparty%2Fgcc.git [Ada] Speed up enumeration'Value with perfect hash function gcc/ada/ * Makefile.rtl (GNATRTL_NONTASKING_OBJS): Add s-imagen, s-imen16, s-imen32, s-imenu8, s-pehage, s-valuen, s-vaen16, s-vaen32 and s-vaenu8. Remove s-imenne, s-imgenu and s-valenu. * debug.adb (d_h): Document new usage. * einfo.ads (Lit_Hash): New attribute for enumeration types. (Set_Lit_Hash): Declare. * einfo.adb (Lit_Hash): New function. (Set_Lit_Hash): New procedure. (Write_Field21_Name): Print Lit_Hash for Enumeration_Kind. * exp_imgv.ads (Build_Enumeration_Image_Tables): Fix description and document the hash function and its tables. * exp_imgv.adb: Add with/use clauses for Debug. Add with clause for System.Perfect_Hash_Generators. (Append_Table_To): New helper routine. (Build_Enumeration_Image_Tables): Call it to build the tables. In the main unit, register the literals with the hash generator. If they are sufficiently many and -gnatd_h is not passed, generate a perfect hash function and its tables; otherwise, generate a dummy hash function. For the other units, generate only the declaration. In all cases, set Lit_Hash to the entity of the function, if any. (Expand_Value_Attribute): Pass the 'Unrestricted_Access of Lit_Hash, if any, as third argument to the Value_Enumeration_NN function. * gnat1drv.adb (Adjust_Global_Switches): force simpler implementation of 'Value in CodePeer_Mode. * lib.ads (Synchronize_Serial_Number): Add SN parameter. * lib.adb (Synchronize_Serial_Number): Assert that it is larger than the serial number of the current unit and set the latter to it only in this case. * rtsfind.ads (RTU_Id): Add System_Img_Enum_8, System_Img_Enum_16, System_Img_Enum_32, System_Val_Enum_8, System_Val_Enum_16 and System_Val_Enum_32. Remove System_Img_Enum, System_Img_Enum_New and System_Val_Enum. * sem_attr.adb (Analyze_Access_Attribute): Do not flag a compiler generated Unrestricted_Access attribute as illegal in a declare expression. (RE_Unit_Table): Adjust to above changes. * libgnat/g-heasor.ads: Add pragma Compiler_Unit_Warning. * libgnat/g-table.ads: Likewise. * libgnat/g-pehage.ads: Add with clause and local renaming for System.Perfect_Hash_Generators. (Optimization): Turn into derived type. (Verbose): Turn into renaming. (Too_Many_Tries): Likewise. (Table_Name): Move to System.Perfect_Hash_Generators. (Define): Likewise. (Value): Likewise. * libgnat/g-pehage.adb: Remove with clause for Ada.Directories, GNAT.Heap_Sort_G and GNAT.Table. Move bulk of implementation to System.Perfect_Hash_Generators, only keep the output part. * libgnat/s-imagen.ads: New generic unit. * libgnat/s-imagen.adb: New body. * libgnat/s-imen16.ads: New unit. * libgnat/s-imen32.ads: Likewise. * libgnat/s-imenu8.ads: Likewise. * libgnat/s-imenne.ads: Adjust description. * libgnat/s-imgenu.ads: Delete. * libgnat/s-imgenu.adb: Likewise. * libgnat/s-pehage.ads: New unit from GNAT.Perfect_Hash_Generators. * libgnat/s-pehage.adb: New body from GNAT.Perfect_Hash_Generators. * libgnat/s-valuen.ads: New generic unit. * libgnat/s-valuen.adb: New body. * libgnat/s-vaen16.ads: New unit. * libgnat/s-vaen32.ads: Likewise. * libgnat/s-vaenu8.ads: Likewise. * libgnat/s-valenu.ads: Delete. * libgnat/s-valenu.adb: Likewise. * gcc-interface/Make-lang.in (GNAT_ADA_OBJS): Add s-pehage.o. (GNATBIND_OBJS): Remove s-imgenu.o. --- diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index d42579d5f0d1..32081c972a8d 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -619,18 +619,20 @@ GNATRTL_NONTASKING_OBJS= \ s-imaged$(objext) \ s-imagef$(objext) \ s-imagei$(objext) \ + s-imagen$(objext) \ s-imager$(objext) \ s-imageu$(objext) \ s-imagew$(objext) \ s-imde32$(objext) \ s-imde64$(objext) \ - s-imenne$(objext) \ + s-imen16$(objext) \ + s-imen32$(objext) \ + s-imenu8$(objext) \ s-imfi32$(objext) \ s-imfi64$(objext) \ s-imgbiu$(objext) \ s-imgboo$(objext) \ s-imgcha$(objext) \ - s-imgenu$(objext) \ s-imgflt$(objext) \ s-imgint$(objext) \ s-imglfl$(objext) \ @@ -714,6 +716,7 @@ GNATRTL_NONTASKING_OBJS= \ s-pack63$(objext) \ s-parame$(objext) \ s-parint$(objext) \ + s-pehage$(objext) \ s-pooglo$(objext) \ s-pooloc$(objext) \ s-poosiz$(objext) \ @@ -759,9 +762,11 @@ GNATRTL_NONTASKING_OBJS= \ s-valcha$(objext) \ s-vade32$(objext) \ s-vade64$(objext) \ + s-vaen16$(objext) \ + s-vaen32$(objext) \ + s-vaenu8$(objext) \ s-vafi32$(objext) \ s-vafi64$(objext) \ - s-valenu$(objext) \ s-valflt$(objext) \ s-valint$(objext) \ s-vallfl$(objext) \ @@ -772,6 +777,7 @@ GNATRTL_NONTASKING_OBJS= \ s-valued$(objext) \ s-valuef$(objext) \ s-valuei$(objext) \ + s-valuen$(objext) \ s-valuer$(objext) \ s-valueu$(objext) \ s-valuns$(objext) \ diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index d557ed1d4af6..784c7e0d4b06 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -146,7 +146,7 @@ package body Debug is -- d_e Ignore entry calls and requeue statements for elaboration -- d_f Issue info messages related to GNATprove usage -- d_g - -- d_h + -- d_h Disable the use of (perfect) hash functions for enumeration Value -- d_i Ignore activations and calls to instances for elaboration -- d_j Read JSON files and populate Repinfo tables (opposite of -gnatRjs) -- d_k @@ -971,6 +971,9 @@ package body Debug is -- beginners find them confusing. Set automatically by GNATprove when -- switch --info is used. + -- d_h The compiler does not make use of (perfect) hash functions in the + -- implementation of the Value attribute for enumeration types. + -- d_i The compiler ignores calls and task activations when they target a -- subprogram or task type defined in an external instance for both -- the static and dynamic elaboration models. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 2dd448c15634..2da6f4465f97 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -180,6 +180,7 @@ package body Einfo is -- Corresponding_Record_Component Node21 -- Default_Expr_Function Node21 -- Discriminant_Constraint Elist21 + -- Lit_Hash Node21 -- Interface_Name Node21 -- Original_Array_Type Node21 -- Small_Value Ureal21 @@ -2836,6 +2837,12 @@ package body Einfo is return Node33 (Id); end Linker_Section_Pragma; + function Lit_Hash (Id : E) return E is + begin + pragma Assert (Is_Enumeration_Type (Id)); + return Node21 (Id); + end Lit_Hash; + function Lit_Indexes (Id : E) return E is begin pragma Assert (Is_Enumeration_Type (Id)); @@ -6103,6 +6110,12 @@ package body Einfo is Set_Node33 (Id, V); end Set_Linker_Section_Pragma; + procedure Set_Lit_Hash (Id : E; V : E) is + begin + pragma Assert (Is_Enumeration_Type (Id) and then Root_Type (Id) = Id); + Set_Node21 (Id, V); + end Set_Lit_Hash; + procedure Set_Lit_Indexes (Id : E; V : E) is begin pragma Assert (Is_Enumeration_Type (Id) and then Root_Type (Id) = Id); @@ -10884,6 +10897,9 @@ package body Einfo is => Write_Str ("Interface_Name"); + when Enumeration_Kind => + Write_Str ("Lit_Hash"); + when Array_Kind | Modular_Integer_Kind => diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index abc3a887e651..a88f1fd2d875 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3498,6 +3498,13 @@ package Einfo is -- field may be set as a result of a linker section pragma applied to the -- type of the object. +-- Lit_Hash (Node21) +-- Defined in enumeration types and subtypes. Non-empty only for the +-- case of an enumeration root type, where it contains the entity for +-- the generated hash function. See unit Exp_Imgv for full details of +-- the nature and use of this entity for implementing the Value +-- attribute for the enumeration type in question. + -- Lit_Indexes (Node18) -- Defined in enumeration types and subtypes. Non-empty only for the -- case of an enumeration root type, where it contains the entity for @@ -6150,6 +6157,7 @@ package Einfo is -- Lit_Indexes (Node18) (root type only) -- Default_Aspect_Value (Node19) (base type only) -- Scalar_Range (Node20) + -- Lit_Hash (Node21) (root type only) -- Enum_Pos_To_Rep (Node23) (type only) -- Static_Discrete_Predicate (List25) -- Has_Biased_Representation (Flag139) @@ -7469,6 +7477,7 @@ package Einfo is function Last_Entity (Id : E) return E; function Limited_View (Id : E) return E; function Linker_Section_Pragma (Id : E) return N; + function Lit_Hash (Id : E) return E; function Lit_Indexes (Id : E) return E; function Lit_Strings (Id : E) return E; function Low_Bound_Tested (Id : E) return B; @@ -8191,6 +8200,7 @@ package Einfo is procedure Set_Last_Entity (Id : E; V : E); procedure Set_Limited_View (Id : E; V : E); procedure Set_Linker_Section_Pragma (Id : E; V : N); + procedure Set_Lit_Hash (Id : E; V : E); procedure Set_Lit_Indexes (Id : E; V : E); procedure Set_Lit_Strings (Id : E; V : E); procedure Set_Low_Bound_Tested (Id : E; V : B := True); @@ -9073,6 +9083,7 @@ package Einfo is pragma Inline (Limited_View); pragma Inline (Link_Entities); pragma Inline (Linker_Section_Pragma); + pragma Inline (Lit_Hash); pragma Inline (Lit_Indexes); pragma Inline (Lit_Strings); pragma Inline (Low_Bound_Tested); @@ -9643,6 +9654,7 @@ package Einfo is pragma Inline (Set_Last_Entity); pragma Inline (Set_Limited_View); pragma Inline (Set_Linker_Section_Pragma); + pragma Inline (Set_Lit_Hash); pragma Inline (Set_Lit_Indexes); pragma Inline (Set_Lit_Strings); pragma Inline (Set_Low_Bound_Tested); diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index da98af7bcaec..b060af405618 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -26,6 +26,7 @@ with Atree; use Atree; with Casing; use Casing; with Checks; use Checks; +with Debug; use Debug; with Einfo; use Einfo; with Exp_Put_Image; with Exp_Util; use Exp_Util; @@ -47,6 +48,8 @@ with Ttypes; use Ttypes; with Uintp; use Uintp; with Urealp; use Urealp; +with System.Perfect_Hash_Generators; + package body Exp_Imgv is procedure Rewrite_Object_Image @@ -65,21 +68,88 @@ package body Exp_Imgv is ------------------------------------ procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is - Loc : constant Source_Ptr := Sloc (E); + Loc : constant Source_Ptr := Sloc (E); + In_Main_Unit : constant Boolean := In_Extended_Main_Code_Unit (Loc); + Act : List_Id; Eind : Entity_Id; Estr : Entity_Id; + H_Id : Entity_Id; + H_OK : Boolean; + H_Sp : Node_Id; Ind : List_Id; Ityp : Node_Id; Len : Nat; Lit : Entity_Id; Nlit : Nat; + S_Id : Entity_Id; + S_N : Nat; Str : String_Id; + package SPHG renames System.Perfect_Hash_Generators; + Saved_SSO : constant Character := Opt.Default_SSO; -- Used to save the current scalar storage order during the generation -- of the literal lookup table. + Serial_Number_Budget : constant := 50; + -- We may want to compute a perfect hash function for use by the Value + -- attribute. However computing this function is costly and, therefore, + -- cannot be done when compiling every unit where the enumeration type + -- is referenced, so we do it only when compiling the unit where it is + -- declared. This means that we may need to control the internal serial + -- numbers of this unit, or else we would risk generating public symbols + -- with mismatched names later on. The strategy for this is to allocate + -- a fixed budget of serial numbers to be spent from a specified point + -- until the end of the processing and to make sure that it is always + -- exactly spent on all possible paths from this point. + + Threshold : constant := 3; + -- Threshold above which we want to generate the hash function in the + -- default case. + + Threshold_For_Size : constant := 9; + -- But the function and its tables take a bit of space so the threshold + -- is raised when compiling for size. + + procedure Append_Table_To + (L : List_Id; + E : Entity_Id; + UB : Nat; + Ctyp : Entity_Id; + V : List_Id); + -- Append to L the declaration of E as a constant array of range 0 .. UB + -- and component type Ctyp with initial value V. + + --------------------- + -- Append_Table_To -- + --------------------- + + procedure Append_Table_To + (L : List_Id; + E : Entity_Id; + UB : Nat; + Ctyp : Entity_Id; + V : List_Id) + is + begin + Append_To (L, + Make_Object_Declaration (Loc, + Defining_Identifier => E, + Constant_Present => True, + Object_Definition => + Make_Constrained_Array_Definition (Loc, + Discrete_Subtype_Definitions => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 0), + High_Bound => Make_Integer_Literal (Loc, UB))), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => New_Occurrence_Of (Ctyp, Loc))), + Expression => Make_Aggregate (Loc, Expressions => V))); + end Append_Table_To; + begin -- Nothing to do for types other than a root enumeration type @@ -99,10 +169,10 @@ package body Exp_Imgv is Lit := First_Literal (E); Len := 1; Nlit := 0; + H_OK := False; loop - Append_To (Ind, - Make_Integer_Literal (Loc, UI_From_Int (Len))); + Append_To (Ind, Make_Integer_Literal (Loc, UI_From_Int (Len))); exit when No (Lit); Nlit := Nlit + 1; @@ -114,6 +184,9 @@ package body Exp_Imgv is end if; Store_String_Chars (Name_Buffer (1 .. Name_Len)); + if In_Main_Unit then + SPHG.Insert (Name_Buffer (1 .. Name_Len)); + end if; Len := Len + Int (Name_Len); Next_Literal (Lit); end loop; @@ -148,7 +221,7 @@ package body Exp_Imgv is -- Generate literal table - Insert_Actions (N, + Act := New_List ( Make_Object_Declaration (Loc, Defining_Identifier => Estr, @@ -157,27 +230,420 @@ package body Exp_Imgv is New_Occurrence_Of (Standard_String, Loc), Expression => Make_String_Literal (Loc, - Strval => Str)), + Strval => Str))); - Make_Object_Declaration (Loc, - Defining_Identifier => Eind, - Constant_Present => True, + -- Generate index table - Object_Definition => - Make_Constrained_Array_Definition (Loc, - Discrete_Subtype_Definitions => New_List ( - Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, 0), - High_Bound => Make_Integer_Literal (Loc, Nlit))), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => New_Occurrence_Of (Ityp, Loc))), + Append_Table_To (Act, Eind, Nlit, Ityp, Ind); - Expression => - Make_Aggregate (Loc, - Expressions => Ind))), - Suppress => All_Checks); + -- If the number of literals is at most 3, then we are done. Otherwise + -- we compute a (perfect) hash function for use by the Value attribute. + + if Nlit > Threshold then + -- We start to count serial numbers from here + + S_N := Increment_Serial_Number; + + -- Generate specification of hash function + + H_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (E), 'H')); + Set_Ekind (H_Id, E_Function); + Set_Is_Internal (H_Id); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (H_Id); + end if; + + Set_Lit_Hash (E, H_Id); + + S_Id := Make_Temporary (Loc, 'S'); + + H_Sp := Make_Function_Specification (Loc, + Defining_Unit_Name => H_Id, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => S_Id, + Parameter_Type => + New_Occurrence_Of (Standard_String, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Natural, Loc)); + + -- If the unit where the type is declared is the main unit, and the + -- number of literals is greater than Threshold_For_Size when we are + -- optimizing for size, and -gnatd_h is not specified, try to compute + -- the hash function. + + if In_Main_Unit + and then (Optimize_Size = 0 or else Nlit > Threshold_For_Size) + and then not Debug_Flag_Underscore_H + then + declare + LB : constant Positive := 2 * Positive (Nlit) + 1; + UB : constant Positive := LB + 24; + + begin + -- Try at most 25 * 4 times to compute the hash function before + -- giving up and using a linear search for the Value attribute. + + for V in LB .. UB loop + begin + SPHG.Initialize (4321, V, SPHG.Memory_Space, Tries => 4); + SPHG.Compute (""); + H_OK := True; + exit; + exception + when SPHG.Too_Many_Tries => null; + end; + end loop; + end; + end if; + + -- If the hash function has been successfully computed, 4 more tables + -- named P, T1, T2 and G are needed. The hash function is of the form + + -- function Hash (S : String) return Natural is + -- F : constant Natural := S'First - 1; + -- L : constant Natural := S'Length; + -- A, B : Natural := 0; + -- J : Natural; + + -- begin + -- for K in P'Range loop + -- exit when L < P (K); + -- J := Character'Pos (S (P (K) + F)); + -- A := (A + Natural (T1 (K) * J)) mod N; + -- B := (B + Natural (T2 (K) * J)) mod N; + -- end loop; + + -- return (Natural (G (A)) + Natural (G (B))) mod M; + -- end Hash; + + -- where N is the length of G and M the number of literals. + + if H_OK then + declare + Siz, L1, L2 : Natural; + I : Int; + + Pos, T1, T2, G : List_Id; + EPos, ET1, ET2, EG : Entity_Id; + + F, L, A, B, J, K : Entity_Id; + Body_Decls : List_Id; + Body_Stmts : List_Id; + Loop_Stmts : List_Id; + + begin + -- Generate position table + + SPHG.Define (SPHG.Character_Position, Siz, L1, L2); + Pos := New_List; + for J in 0 .. L1 - 1 loop + I := Int (SPHG.Value (SPHG.Character_Position, J)); + Append_To (Pos, Make_Integer_Literal (Loc, UI_From_Int (I))); + end loop; + + EPos := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (E), 'P')); + + Append_Table_To + (Act, EPos, Nat (L1 - 1), Standard_Natural, Pos); + + -- Generate function table 1 + + SPHG.Define (SPHG.Function_Table_1, Siz, L1, L2); + T1 := New_List; + for J in 0 .. L1 - 1 loop + I := Int (SPHG.Value (SPHG.Function_Table_1, J)); + Append_To (T1, Make_Integer_Literal (Loc, UI_From_Int (I))); + end loop; + + ET1 := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (E), "T1")); + + Ityp := + Small_Integer_Type_For (UI_From_Int (Int (Siz)), Uns => True); + Append_Table_To (Act, ET1, Nat (L1 - 1), Ityp, T1); + + -- Generate function table 2 + + SPHG.Define (SPHG.Function_Table_2, Siz, L1, L2); + T2 := New_List; + for J in 0 .. L1 - 1 loop + I := Int (SPHG.Value (SPHG.Function_Table_2, J)); + Append_To (T2, Make_Integer_Literal (Loc, UI_From_Int (I))); + end loop; + + ET2 := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (E), "T2")); + + Ityp := + Small_Integer_Type_For (UI_From_Int (Int (Siz)), Uns => True); + Append_Table_To (Act, ET2, Nat (L1 - 1), Ityp, T2); + + -- Generate graph table + + SPHG.Define (SPHG.Graph_Table, Siz, L1, L2); + G := New_List; + for J in 0 .. L1 - 1 loop + I := Int (SPHG.Value (SPHG.Graph_Table, J)); + Append_To (G, Make_Integer_Literal (Loc, UI_From_Int (I))); + end loop; + + EG := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (E), 'G')); + + Ityp := + Small_Integer_Type_For (UI_From_Int (Int (Siz)), Uns => True); + Append_Table_To (Act, EG, Nat (L1 - 1), Ityp, G); + + -- Generate body of hash function + + F := Make_Temporary (Loc, 'F'); + + Body_Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => F, + Object_Definition => + New_Occurrence_Of (Standard_Natural, Loc), + Expression => + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (S_Id, Loc), + Attribute_Name => Name_First), + Right_Opnd => + Make_Integer_Literal (Loc, 1)))); + + L := Make_Temporary (Loc, 'L'); + + Append_To (Body_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => L, + Object_Definition => + New_Occurrence_Of (Standard_Natural, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (S_Id, Loc), + Attribute_Name => Name_Length))); + + A := Make_Temporary (Loc, 'A'); + + Append_To (Body_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => A, + Object_Definition => + New_Occurrence_Of (Standard_Natural, Loc), + Expression => Make_Integer_Literal (Loc, 0))); + + B := Make_Temporary (Loc, 'B'); + + Append_To (Body_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => B, + Object_Definition => + New_Occurrence_Of (Standard_Natural, Loc), + Expression => Make_Integer_Literal (Loc, 0))); + + J := Make_Temporary (Loc, 'J'); + + Append_To (Body_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => J, + Object_Definition => + New_Occurrence_Of (Standard_Natural, Loc))); + + K := Make_Temporary (Loc, 'K'); + + -- Generate exit when L < P (K); + + Loop_Stmts := New_List ( + Make_Exit_Statement (Loc, + Condition => + Make_Op_Lt (Loc, + Left_Opnd => New_Occurrence_Of (L, Loc), + Right_Opnd => + Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (EPos, Loc), + Expressions => New_List ( + New_Occurrence_Of (K, Loc)))))); + + -- Generate J := Character'Pos (S (P (K) + F)); + + Append_To (Loop_Stmts, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (J, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Standard_Character, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (S_Id, Loc), + Expressions => New_List ( + Make_Op_Add (Loc, + Left_Opnd => + Make_Indexed_Component (Loc, + Prefix => + New_Occurrence_Of (EPos, Loc), + Expressions => New_List ( + New_Occurrence_Of (K, Loc))), + Right_Opnd => + New_Occurrence_Of (F, Loc)))))))); + + -- Generate A := (A + Natural (T1 (K) * J)) mod N; + + Append_To (Loop_Stmts, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (A, Loc), + Expression => + Make_Op_Mod (Loc, + Left_Opnd => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (A, Loc), + Right_Opnd => + Make_Op_Multiply (Loc, + Left_Opnd => + Convert_To (Standard_Natural, + Make_Indexed_Component (Loc, + Prefix => + New_Occurrence_Of (ET1, Loc), + Expressions => New_List ( + New_Occurrence_Of (K, Loc)))), + Right_Opnd => New_Occurrence_Of (J, Loc))), + Right_Opnd => Make_Integer_Literal (Loc, Int (L1))))); + + -- Generate B := (B + Natural (T2 (K) * J)) mod N; + + Append_To (Loop_Stmts, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (B, Loc), + Expression => + Make_Op_Mod (Loc, + Left_Opnd => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (B, Loc), + Right_Opnd => + Make_Op_Multiply (Loc, + Left_Opnd => + Convert_To (Standard_Natural, + Make_Indexed_Component (Loc, + Prefix => + New_Occurrence_Of (ET2, Loc), + Expressions => New_List ( + New_Occurrence_Of (K, Loc)))), + Right_Opnd => New_Occurrence_Of (J, Loc))), + Right_Opnd => Make_Integer_Literal (Loc, Int (L1))))); + + -- Generate loop + + Body_Stmts := New_List ( + Make_Implicit_Loop_Statement (N, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => K, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (EPos, Loc), + Attribute_Name => Name_Range))), + Statements => Loop_Stmts)); + + -- Generate return (Natural (G (A)) + Natural (G (B))) mod M; + + Append_To (Body_Stmts, + Make_Simple_Return_Statement (Loc, + Expression => + Make_Op_Mod (Loc, + Left_Opnd => + Make_Op_Add (Loc, + Left_Opnd => + Convert_To (Standard_Natural, + Make_Indexed_Component (Loc, + Prefix => + New_Occurrence_Of (EG, Loc), + Expressions => New_List ( + New_Occurrence_Of (A, Loc)))), + Right_Opnd => + Convert_To (Standard_Natural, + Make_Indexed_Component (Loc, + Prefix => + New_Occurrence_Of (EG, Loc), + Expressions => New_List ( + New_Occurrence_Of (B, Loc))))), + Right_Opnd => Make_Integer_Literal (Loc, Nlit)))); + + -- Generate final body + + Append_To (Act, + Make_Subprogram_Body (Loc, + Specification => H_Sp, + Declarations => Body_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Body_Stmts))); + end; + + -- If we chose not to or did not manage to compute the hash function, + -- we need to build a dummy function always returning Natural'Last + -- because other units reference it if they use the Value attribute. + + elsif In_Main_Unit then + declare + Body_Stmts : List_Id; + + begin + -- Generate return Natural'Last + + Body_Stmts := New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Standard_Natural, Loc), + Attribute_Name => Name_Last))); + + -- Generate body + + Append_To (Act, + Make_Subprogram_Body (Loc, + Specification => H_Sp, + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Body_Stmts))); + end; + + -- For the other units, just declare the function + + else + Append_To (Act, + Make_Subprogram_Declaration (Loc, Specification => H_Sp)); + end if; + + else + Set_Lit_Hash (E, Empty); + end if; + + if In_Main_Unit then + System.Perfect_Hash_Generators.Finalize; + end if; + + Insert_Actions (N, Act, Suppress => All_Checks); + + -- This is where we check that our budget of serial numbers has been + -- entirely spent, see the declaration of Serial_Number_Budget above. + + if Nlit > Threshold then + Synchronize_Serial_Number (S_N + Serial_Number_Budget); + end if; -- Reset the scalar storage order to the saved value @@ -916,15 +1382,17 @@ package body Exp_Imgv is -- For enumeration types other than those derived from types Boolean, -- Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to: - -- Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X)) + -- Enum'Val + -- (Value_Enumeration_NN + -- (typS, typN'Address, typH'Unrestricted_Access, Num, X)) - -- where typS and typI and the Lit_Strings and Lit_Indexes entities - -- from T's root type entity, and Num is Enum'Pos (Enum'Last). The - -- Value_Enumeration_NN function will search the tables looking for + -- where typS, typN and typH are the Lit_Strings, Lit_Indexes and Lit_Hash + -- entities from T's root type entity, and Num is Enum'Pos (Enum'Last). + -- The Value_Enumeration_NN function will search the tables looking for -- X and return the position number in the table if found which is -- used to provide the result of 'Value (using Enum'Val). If the -- value is not found Constraint_Error is raised. The suffix _NN - -- depends on the element type of typI. + -- depends on the element type of typN. procedure Expand_Value_Attribute (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); @@ -1083,10 +1551,11 @@ package body Exp_Imgv is Analyze_And_Resolve (N, Btyp); - -- Here for normal case where we have enumeration tables, this - -- is where we build + -- Normal case where we have enumeration tables, build - -- T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X)) + -- T'Val + -- (Value_Enumeration_NN + -- (typS, typN'Address, typH'Unrestricted_Access, Num, X)) else Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); @@ -1108,6 +1577,15 @@ package body Exp_Imgv is Prefix => New_Occurrence_Of (Rtyp, Loc), Attribute_Name => Name_Last)))); + if Present (Lit_Hash (Rtyp)) then + Prepend_To (Args, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Lit_Hash (Rtyp), Loc), + Attribute_Name => Name_Unrestricted_Access)); + else + Prepend_To (Args, Make_Null (Loc)); + end if; + Prepend_To (Args, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc), diff --git a/gcc/ada/exp_imgv.ads b/gcc/ada/exp_imgv.ads index ce3ec2fc9527..76e1ca622176 100644 --- a/gcc/ada/exp_imgv.ads +++ b/gcc/ada/exp_imgv.ads @@ -35,39 +35,49 @@ package Exp_Imgv is -- base type. The node N is the point in the tree where the resulting -- declarations are to be inserted. -- - -- The form of the tables generated is as follows: + -- The form of the tables generated is as follows: -- - -- xxxS : string := "chars"; - -- xxxI : array (0 .. N) of Natural_8/16/32 := (1, n, .., n); + -- xxxS : constant string (1 .. M) := "chars"; + -- xxxN : constant array (0 .. N) of Index_Type := (i1, i2, .., iN, j); -- - -- Here xxxS is a string obtained by concatenating all the names - -- of the enumeration literals in sequence, representing any wide - -- characters according to the current wide character encoding - -- method, and with all letters forced to upper case. + -- Here xxxS is a string obtained by concatenating all the names of the + -- enumeration literals in sequence, representing any wide characters + -- according to the current wide character encoding method, and with all + -- letters forced to upper case. -- - -- The array xxxI is an array of ones origin indexes to the start - -- of each name, with one extra entry at the end, which is the index - -- to the character just past the end of the last literal, i.e. it is - -- the length of xxxS + 1. The element type is the shortest of the - -- possible types that will hold all the values. + -- The array xxxN is an array of indexes into xxxS pointing to the start + -- of each name, with one extra entry at the end, which is the index to + -- the character just past the end of the last literal, i.e. it is the + -- length of xxxS + 1. The element type is the shortest of the possible + -- types that will hold all the values. -- - -- For example, for the type + -- For example, for the type -- - -- type x is (hello,'!',goodbye); + -- type x is (hello,'!',goodbye); -- - -- the generated tables would consist of + -- the generated tables would consist of -- - -- xxxS : String := "hello'!'goodbye"; - -- xxxI : array (0 .. 3) of Natural_8 := (1, 6, 9, 16); + -- xxxS : constant string (1 .. 15) := "hello'!'goodbye"; + -- xxxN : constant array (0 .. 3) of Integer_8 := (1, 6, 9, 16); -- - -- Here Natural_8 is used since 16 < 2**(8-1) + -- Here Integer_8 is used since 16 < 2**(8-1). -- - -- If the entity E needs the tables constructing, the necessary - -- declarations are constructed, and the fields Lit_Strings and - -- Lit_Indexes of E are set to point to the corresponding entities. - -- If no tables are needed (E is not a user defined enumeration - -- root type, or pragma Discard_Names is in effect, then the - -- declarations are not constructed, and the fields remain Empty. + -- If the entity E needs the tables, the necessary declarations are built + -- and the fields Lit_Strings and Lit_Indexes of E are set to point to the + -- corresponding entities. If no tables are needed (E is not a user defined + -- enumeration root type, or pragma Discard_Names is in effect), then the + -- declarations are not constructed and the fields remain Empty. + -- + -- If the number of enumeration literals is large enough, a (perfect) hash + -- function mapping the literals to their position number is also built and + -- requires in turn to build four additional tables: + -- + -- xxxP : constant array (0 .. X - 1) of Natural = (p1, p2, ..., pX); + -- xxxT1 : constant array (0 .. Y - 1) of Index_Type = (q1, ..., qY); + -- xxxT2 : constant array (0 .. Y - 1) of Index_Type = (r1, ..., rY); + -- xxxG : constant array (0 .. Z - 1) of Index_Type = (s1, ..., sZ); + -- + -- See the System.Perfect_Hash_Generators unit for a complete description. procedure Expand_Image_Attribute (N : Node_Id); -- This procedure is called from Exp_Attr to expand an occurrence of the diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 6c2723943612..6e873e25f0d6 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -390,6 +390,7 @@ GNAT_ADA_OBJS = \ ada/libgnat/s-memory.o \ ada/libgnat/s-os_lib.o \ ada/libgnat/s-parame.o \ + ada/libgnat/s-pehage.o \ ada/libgnat/s-purexc.o \ ada/libgnat/s-restri.o \ ada/libgnat/s-secsta.o \ @@ -585,7 +586,6 @@ GNATBIND_OBJS = \ ada/libgnat/s-exctab.o \ ada/libgnat/s-htable.o \ ada/libgnat/s-imenne.o \ - ada/libgnat/s-imgenu.o \ ada/libgnat/s-imgint.o \ ada/libgnat/s-mastop.o \ ada/libgnat/s-memory.o \ diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 40f9228dd5c4..448a64066689 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -423,6 +423,12 @@ procedure Gnat1drv is if Warning_Mode = Suppress then Debug_Flag_MM := True; end if; + + -- The implementation of 'Value that uses a perfect hash function + -- is significantly more complex and harder to initialize than the + -- old implementation. Deactivate it for CodePeer. + + Debug_Flag_Underscore_H := True; end if; -- Enable some individual switches that are implied by relaxed RM diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb index 1aeedad83957..f347b8cae2d5 100644 --- a/gcc/ada/lib.adb +++ b/gcc/ada/lib.adb @@ -1266,10 +1266,16 @@ package body Lib is -- Synchronize_Serial_Number -- ------------------------------- - procedure Synchronize_Serial_Number is + procedure Synchronize_Serial_Number (SN : Nat) is TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number; begin - TSN := TSN + 1; + -- We should not be trying to synchronize downward + + pragma Assert (TSN <= SN); + + if TSN < SN then + TSN := SN; + end if; end Synchronize_Serial_Number; -------------------- diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index 57fe50310de1..1450124c99ef 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -741,13 +741,13 @@ package Lib is -- This procedure is called to register a pragma N for which a notes -- entry is required. - procedure Synchronize_Serial_Number; + procedure Synchronize_Serial_Number (SN : Nat); -- This function increments the Serial_Number field for the current unit - -- but does not return the incremented value. This is used when there - -- is a situation where one path of control increments a serial number - -- (using Increment_Serial_Number), and the other path does not and it is - -- important to keep the serial numbers synchronized in the two cases (e.g. - -- when the references in a package and a client must be kept consistent). + -- up to SN if it is initially lower and does nothing otherwise. This is + -- used in situations where one path of control increments serial numbers + -- and the other path does not and it is important to keep serial numbers + -- synchronized in the two cases (e.g. when the references in a package + -- and a client must be kept consistent). procedure Unlock; -- Unlock internal tables, in cases where the back end needs to modify them diff --git a/gcc/ada/libgnat/g-heasor.ads b/gcc/ada/libgnat/g-heasor.ads index 2361c88c52c4..6bc026f3db8e 100644 --- a/gcc/ada/libgnat/g-heasor.ads +++ b/gcc/ada/libgnat/g-heasor.ads @@ -46,6 +46,8 @@ -- Note: GNAT.Heap_Sort replaces and obsoletes GNAT.Heap_Sort_A, which is -- retained in the GNAT library for backwards compatibility. +pragma Compiler_Unit_Warning; + package GNAT.Heap_Sort is pragma Pure; diff --git a/gcc/ada/libgnat/g-pehage.adb b/gcc/ada/libgnat/g-pehage.adb index 84b74b59f76d..606656b1fdda 100644 --- a/gcc/ada/libgnat/g-pehage.adb +++ b/gcc/ada/libgnat/g-pehage.adb @@ -31,124 +31,18 @@ with Ada.IO_Exceptions; use Ada.IO_Exceptions; with Ada.Characters.Handling; use Ada.Characters.Handling; -with Ada.Directories; -with GNAT.Heap_Sort_G; -with GNAT.OS_Lib; use GNAT.OS_Lib; -with GNAT.Table; +with GNAT.OS_Lib; use GNAT.OS_Lib; package body GNAT.Perfect_Hash_Generators is - -- We are using the algorithm of J. Czech as described in Zbigniew J. - -- Czech, George Havas, and Bohdan S. Majewski ``An Optimal Algorithm for - -- Generating Minimal Perfect Hash Functions'', Information Processing - -- Letters, 43(1992) pp.257-264, Oct.1992 - - -- This minimal perfect hash function generator is based on random graphs - -- and produces a hash function of the form: - - -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m - - -- where f1 and f2 are functions that map strings into integers, and g is - -- a function that maps integers into [0, m-1]. h can be order preserving. - -- For instance, let W = {w_0, ..., w_i, ..., w_m-1}, h can be defined - -- such that h (w_i) = i. - - -- This algorithm defines two possible constructions of f1 and f2. Method - -- b) stores the hash function in less memory space at the expense of - -- greater CPU time. - - -- a) fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n - - -- size (Tk) = max (for w in W) (length (w)) * size (used char set) - - -- b) fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n - - -- size (Tk) = max (for w in W) (length (w)) but the table lookups are - -- replaced by multiplications. - - -- where Tk values are randomly generated. n is defined later on but the - -- algorithm recommends to use a value a little bit greater than 2m. Note - -- that for large values of m, the main memory space requirements comes - -- from the memory space for storing function g (>= 2m entries). - - -- Random graphs are frequently used to solve difficult problems that do - -- not have polynomial solutions. This algorithm is based on a weighted - -- undirected graph. It comprises two steps: mapping and assignment. - - -- In the mapping step, a graph G = (V, E) is constructed, where = {0, 1, - -- ..., n-1} and E = {(for w in W) (f1 (w), f2 (w))}. In order for the - -- assignment step to be successful, G has to be acyclic. To have a high - -- probability of generating an acyclic graph, n >= 2m. If it is not - -- acyclic, Tk have to be regenerated. - - -- In the assignment step, the algorithm builds function g. As G is - -- acyclic, there is a vertex v1 with only one neighbor v2. Let w_i be - -- the word such that v1 = f1 (w_i) and v2 = f2 (w_i). Let g (v1) = 0 by - -- construction and g (v2) = (i - g (v1)) mod n (or h (i) - g (v1) mod n). - -- If word w_j is such that v2 = f1 (w_j) and v3 = f2 (w_j), g (v3) = (j - - -- g (v2)) mod (or to be general, (h (j) - g (v2)) mod n). If w_i has no - -- neighbor, then another vertex is selected. The algorithm traverses G to - -- assign values to all the vertices. It cannot assign a value to an - -- already assigned vertex as G is acyclic. - - subtype Word_Id is Integer; - subtype Key_Id is Integer; - subtype Vertex_Id is Integer; - subtype Edge_Id is Integer; - subtype Table_Id is Integer; - - No_Vertex : constant Vertex_Id := -1; - No_Edge : constant Edge_Id := -1; - No_Table : constant Table_Id := -1; - - type Word_Type is new String_Access; - procedure Free_Word (W : in out Word_Type) renames Free; - function New_Word (S : String) return Word_Type; - - procedure Resize_Word (W : in out Word_Type; Len : Natural); - -- Resize string W to have a length Len - - type Key_Type is record - Edge : Edge_Id; - end record; - -- A key corresponds to an edge in the algorithm graph - - type Vertex_Type is record - First : Edge_Id; - Last : Edge_Id; - end record; - -- A vertex can be involved in several edges. First and Last are the bounds - -- of an array of edges stored in a global edge table. - - type Edge_Type is record - X : Vertex_Id; - Y : Vertex_Id; - Key : Key_Id; - end record; - -- An edge is a peer of vertices. In the algorithm, a key is associated to - -- an edge. - - package WT is new GNAT.Table (Word_Type, Word_Id, 0, 32, 32); - package IT is new GNAT.Table (Integer, Integer, 0, 32, 32); - -- The two main tables. WT is used to store the words in their initial - -- version and in their reduced version (that is words reduced to their - -- significant characters). As an instance of GNAT.Table, WT does not - -- initialize string pointers to null. This initialization has to be done - -- manually when the table is allocated. IT is used to store several - -- tables of components containing only integers. + use SPHG; function Image (Int : Integer; W : Natural := 0) return String; function Image (Str : String; W : Natural := 0) return String; -- Return a string which includes string Str or integer Int preceded by -- leading spaces if required by width W. - function Trim_Trailing_Nuls (Str : String) return String; - -- Return Str with trailing NUL characters removed - - Output : File_Descriptor renames GNAT.OS_Lib.Standout; - -- Shortcuts - EOL : constant Character := ASCII.LF; Max : constant := 78; @@ -156,6 +50,12 @@ package body GNAT.Perfect_Hash_Generators is Line : String (1 .. Max); -- Use this line to provide buffered IO + NK : Natural := 0; + -- NK : Number of Keys + + Opt : Optimization; + -- Optimization mode (memory vs CPU) + procedure Add (C : Character); procedure Add (S : String); -- Add a character or a string in Line and update Last @@ -185,324 +85,21 @@ package body GNAT.Perfect_Hash_Generators is procedure Put (File : File_Descriptor; Str : String); -- Simulate Ada.Text_IO.Put with GNAT.OS_Lib - procedure Put_Used_Char_Set (File : File_Descriptor; Title : String); - -- Output a title and a used character set - - procedure Put_Int_Vector - (File : File_Descriptor; - Title : String; - Vector : Integer; - Length : Natural); - -- Output a title and a vector - procedure Put_Int_Matrix (File : File_Descriptor; Title : String; - Table : Table_Id; + Table : Table_Name; Len_1 : Natural; Len_2 : Natural); -- Output a title and a matrix. When the matrix has only one non-empty -- dimension (Len_2 = 0), output a vector. - procedure Put_Edges (File : File_Descriptor; Title : String); - -- Output a title and an edge table - - procedure Put_Initial_Keys (File : File_Descriptor; Title : String); - -- Output a title and a key table - - procedure Put_Reduced_Keys (File : File_Descriptor; Title : String); - -- Output a title and a key table - - procedure Put_Vertex_Table (File : File_Descriptor; Title : String); - -- Output a title and a vertex table - function Ada_File_Base_Name (Pkg_Name : String) return String; -- Return the base file name (i.e. without .ads/.adb extension) for an -- Ada source file containing the named package, using the standard GNAT -- file-naming convention. For example, if Pkg_Name is "Parent.Child", we -- return "parent-child". - ---------------------------------- - -- Character Position Selection -- - ---------------------------------- - - -- We reduce the maximum key size by selecting representative positions - -- in these keys. We build a matrix with one word per line. We fill the - -- remaining space of a line with ASCII.NUL. The heuristic selects the - -- position that induces the minimum number of collisions. If there are - -- collisions, select another position on the reduced key set responsible - -- of the collisions. Apply the heuristic until there is no more collision. - - procedure Apply_Position_Selection; - -- Apply Position selection and build the reduced key table - - procedure Parse_Position_Selection (Argument : String); - -- Parse Argument and compute the position set. Argument is list of - -- substrings separated by commas. Each substring represents a position - -- or a range of positions (like x-y). - - procedure Select_Character_Set; - -- Define an optimized used character set like Character'Pos in order not - -- to allocate tables of 256 entries. - - procedure Select_Char_Position; - -- Find a min char position set in order to reduce the max key length. The - -- heuristic selects the position that induces the minimum number of - -- collisions. If there are collisions, select another position on the - -- reduced key set responsible of the collisions. Apply the heuristic until - -- there is no collision. - - ----------------------------- - -- Random Graph Generation -- - ----------------------------- - - procedure Random (Seed : in out Natural); - -- Simulate Ada.Discrete_Numerics.Random - - procedure Generate_Mapping_Table - (Tab : Table_Id; - L1 : Natural; - L2 : Natural; - Seed : in out Natural); - -- Random generation of the tables below. T is already allocated - - procedure Generate_Mapping_Tables - (Opt : Optimization; - Seed : in out Natural); - -- Generate the mapping tables T1 and T2. They are used to define fk (w) = - -- sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n. Keys, NK and Chars - -- are used to compute the matrix size. - - --------------------------- - -- Algorithm Computation -- - --------------------------- - - procedure Compute_Edges_And_Vertices (Opt : Optimization); - -- Compute the edge and vertex tables. These are empty when a self loop is - -- detected (f1 (w) = f2 (w)). The edge table is sorted by X value and then - -- Y value. Keys is the key table and NK the number of keys. Chars is the - -- set of characters really used in Keys. NV is the number of vertices - -- recommended by the algorithm. T1 and T2 are the mapping tables needed to - -- compute f1 (w) and f2 (w). - - function Acyclic return Boolean; - -- Return True when the graph is acyclic. Vertices is the current vertex - -- table and Edges the current edge table. - - procedure Assign_Values_To_Vertices; - -- Execute the assignment step of the algorithm. Keys is the current key - -- table. Vertices and Edges represent the random graph. G is the result of - -- the assignment step such that: - -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m - - function Sum - (Word : Word_Type; - Table : Table_Id; - Opt : Optimization) return Natural; - -- For an optimization of CPU_Time return - -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n - -- For an optimization of Memory_Space return - -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n - -- Here NV = n - - ------------------------------- - -- Internal Table Management -- - ------------------------------- - - function Allocate (N : Natural; S : Natural := 1) return Table_Id; - -- Allocate N * S ints from IT table - - ---------- - -- Keys -- - ---------- - - Keys : Table_Id := No_Table; - NK : Natural := 0; - -- NK : Number of Keys - - function Initial (K : Key_Id) return Word_Id; - pragma Inline (Initial); - - function Reduced (K : Key_Id) return Word_Id; - pragma Inline (Reduced); - - function Get_Key (N : Key_Id) return Key_Type; - procedure Set_Key (N : Key_Id; Item : Key_Type); - -- Get or Set Nth element of Keys table - - ------------------ - -- Char_Pos_Set -- - ------------------ - - Char_Pos_Set : Table_Id := No_Table; - Char_Pos_Set_Len : Natural; - -- Character Selected Position Set - - function Get_Char_Pos (P : Natural) return Natural; - procedure Set_Char_Pos (P : Natural; Item : Natural); - -- Get or Set the string position of the Pth selected character - - ------------------- - -- Used_Char_Set -- - ------------------- - - Used_Char_Set : Table_Id := No_Table; - Used_Char_Set_Len : Natural; - -- Used Character Set : Define a new character mapping. When all the - -- characters are not present in the keys, in order to reduce the size - -- of some tables, we redefine the character mapping. - - function Get_Used_Char (C : Character) return Natural; - procedure Set_Used_Char (C : Character; Item : Natural); - - ------------ - -- Tables -- - ------------ - - T1 : Table_Id := No_Table; - T2 : Table_Id := No_Table; - T1_Len : Natural; - T2_Len : Natural; - -- T1 : Values table to compute F1 - -- T2 : Values table to compute F2 - - function Get_Table (T : Integer; X, Y : Natural) return Natural; - procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural); - - ----------- - -- Graph -- - ----------- - - G : Table_Id := No_Table; - G_Len : Natural; - -- Values table to compute G - - NT : Natural := Default_Tries; - -- Number of tries running the algorithm before raising an error - - function Get_Graph (N : Natural) return Integer; - procedure Set_Graph (N : Natural; Item : Integer); - -- Get or Set Nth element of graph - - ----------- - -- Edges -- - ----------- - - Edge_Size : constant := 3; - Edges : Table_Id := No_Table; - Edges_Len : Natural; - -- Edges : Edge table of the random graph G - - function Get_Edges (F : Natural) return Edge_Type; - procedure Set_Edges (F : Natural; Item : Edge_Type); - - -------------- - -- Vertices -- - -------------- - - Vertex_Size : constant := 2; - - Vertices : Table_Id := No_Table; - -- Vertex table of the random graph G - - NV : Natural; - -- Number of Vertices - - function Get_Vertices (F : Natural) return Vertex_Type; - procedure Set_Vertices (F : Natural; Item : Vertex_Type); - -- Comments needed ??? - - K2V : Float; - -- Ratio between Keys and Vertices (parameter of Czech's algorithm) - - Opt : Optimization; - -- Optimization mode (memory vs CPU) - - Max_Key_Len : Natural := 0; - Min_Key_Len : Natural := 0; - -- Maximum and minimum of all the word length - - S : Natural; - -- Seed - - function Type_Size (L : Natural) return Natural; - -- Given the last L of an unsigned integer type T, return its size - - ------------- - -- Acyclic -- - ------------- - - function Acyclic return Boolean is - Marks : array (0 .. NV - 1) of Vertex_Id := (others => No_Vertex); - - function Traverse (Edge : Edge_Id; Mark : Vertex_Id) return Boolean; - -- Propagate Mark from X to Y. X is already marked. Mark Y and propagate - -- it to the edges of Y except the one representing the same key. Return - -- False when Y is marked with Mark. - - -------------- - -- Traverse -- - -------------- - - function Traverse (Edge : Edge_Id; Mark : Vertex_Id) return Boolean is - E : constant Edge_Type := Get_Edges (Edge); - K : constant Key_Id := E.Key; - Y : constant Vertex_Id := E.Y; - M : constant Vertex_Id := Marks (E.Y); - V : Vertex_Type; - - begin - if M = Mark then - return False; - - elsif M = No_Vertex then - Marks (Y) := Mark; - V := Get_Vertices (Y); - - for J in V.First .. V.Last loop - - -- Do not propagate to the edge representing the same key - - if Get_Edges (J).Key /= K - and then not Traverse (J, Mark) - then - return False; - end if; - end loop; - end if; - - return True; - end Traverse; - - Edge : Edge_Type; - - -- Start of processing for Acyclic - - begin - -- Edges valid range is - - for J in 1 .. Edges_Len - 1 loop - - Edge := Get_Edges (J); - - -- Mark X of E when it has not been already done - - if Marks (Edge.X) = No_Vertex then - Marks (Edge.X) := Edge.X; - end if; - - -- Traverse E when this has not already been done - - if Marks (Edge.Y) = No_Vertex - and then not Traverse (J, Edge.X) - then - return False; - end if; - end loop; - - return True; - end Acyclic; - ------------------------ -- Ada_File_Base_Name -- ------------------------ @@ -547,559 +144,25 @@ package body GNAT.Perfect_Hash_Generators is Last := Last + Len; end Add; - -------------- - -- Allocate -- - -------------- - - function Allocate (N : Natural; S : Natural := 1) return Table_Id is - L : constant Integer := IT.Last; - begin - IT.Set_Last (L + N * S); - - -- Initialize, so debugging printouts don't trip over uninitialized - -- components. - - for J in L + 1 .. IT.Last loop - IT.Table (J) := -1; - end loop; - - return L + 1; - end Allocate; - - ------------------------------ - -- Apply_Position_Selection -- - ------------------------------ - - procedure Apply_Position_Selection is - begin - for J in 0 .. NK - 1 loop - declare - IW : constant String := WT.Table (Initial (J)).all; - RW : String (1 .. IW'Length) := (others => ASCII.NUL); - N : Natural := IW'First - 1; - - begin - -- Select the characters of Word included in the position - -- selection. - - for C in 0 .. Char_Pos_Set_Len - 1 loop - exit when IW (Get_Char_Pos (C)) = ASCII.NUL; - N := N + 1; - RW (N) := IW (Get_Char_Pos (C)); - end loop; - - -- Build the new table with the reduced word. Be careful - -- to deallocate the old version to avoid memory leaks. - - Free_Word (WT.Table (Reduced (J))); - WT.Table (Reduced (J)) := New_Word (RW); - Set_Key (J, (Edge => No_Edge)); - end; - end loop; - end Apply_Position_Selection; - - ------------------------------- - -- Assign_Values_To_Vertices -- - ------------------------------- - - procedure Assign_Values_To_Vertices is - X : Vertex_Id; - - procedure Assign (X : Vertex_Id); - -- Execute assignment on X's neighbors except the vertex that we are - -- coming from which is already assigned. - - ------------ - -- Assign -- - ------------ - - procedure Assign (X : Vertex_Id) is - E : Edge_Type; - V : constant Vertex_Type := Get_Vertices (X); - - begin - for J in V.First .. V.Last loop - E := Get_Edges (J); - - if Get_Graph (E.Y) = -1 then - pragma Assert (NK /= 0); - Set_Graph (E.Y, (E.Key - Get_Graph (X)) mod NK); - Assign (E.Y); - end if; - end loop; - end Assign; - - -- Start of processing for Assign_Values_To_Vertices - - begin - -- Value -1 denotes an uninitialized value as it is supposed to - -- be in the range 0 .. NK. - - if G = No_Table then - G_Len := NV; - G := Allocate (G_Len, 1); - end if; - - for J in 0 .. G_Len - 1 loop - Set_Graph (J, -1); - end loop; - - for K in 0 .. NK - 1 loop - X := Get_Edges (Get_Key (K).Edge).X; - - if Get_Graph (X) = -1 then - Set_Graph (X, 0); - Assign (X); - end if; - end loop; - - for J in 0 .. G_Len - 1 loop - if Get_Graph (J) = -1 then - Set_Graph (J, 0); - end if; - end loop; - - if Verbose then - Put_Int_Vector (Output, "Assign Values To Vertices", G, G_Len); - end if; - end Assign_Values_To_Vertices; - ------------- -- Compute -- ------------- procedure Compute (Position : String := Default_Position) is - Success : Boolean := False; - begin - if NK = 0 then - raise Program_Error with "keywords set cannot be empty"; - end if; - - if Verbose then - Put_Initial_Keys (Output, "Initial Key Table"); - end if; - - if Position'Length /= 0 then - Parse_Position_Selection (Position); - else - Select_Char_Position; - end if; - - if Verbose then - Put_Int_Vector - (Output, "Char Position Set", Char_Pos_Set, Char_Pos_Set_Len); - end if; - - Apply_Position_Selection; - - if Verbose then - Put_Reduced_Keys (Output, "Reduced Keys Table"); - end if; - - Select_Character_Set; - - if Verbose then - Put_Used_Char_Set (Output, "Character Position Table"); - end if; - - -- Perform Czech's algorithm - - for J in 1 .. NT loop - Generate_Mapping_Tables (Opt, S); - Compute_Edges_And_Vertices (Opt); - - -- When graph is not empty (no self-loop from previous operation) and - -- not acyclic. - - if 0 < Edges_Len and then Acyclic then - Success := True; - exit; - end if; - end loop; - - if not Success then - raise Too_Many_Tries; - end if; - - Assign_Values_To_Vertices; + SPHG.Compute (Position); end Compute; - -------------------------------- - -- Compute_Edges_And_Vertices -- - -------------------------------- - - procedure Compute_Edges_And_Vertices (Opt : Optimization) is - X : Natural; - Y : Natural; - Key : Key_Type; - Edge : Edge_Type; - Vertex : Vertex_Type; - Not_Acyclic : Boolean := False; - - procedure Move (From : Natural; To : Natural); - function Lt (L, R : Natural) return Boolean; - -- Subprograms needed for GNAT.Heap_Sort_G - - -------- - -- Lt -- - -------- - - function Lt (L, R : Natural) return Boolean is - EL : constant Edge_Type := Get_Edges (L); - ER : constant Edge_Type := Get_Edges (R); - begin - return EL.X < ER.X or else (EL.X = ER.X and then EL.Y < ER.Y); - end Lt; - - ---------- - -- Move -- - ---------- - - procedure Move (From : Natural; To : Natural) is - begin - Set_Edges (To, Get_Edges (From)); - end Move; - - package Sorting is new GNAT.Heap_Sort_G (Move, Lt); - - -- Start of processing for Compute_Edges_And_Vertices - - begin - -- We store edges from 1 to 2 * NK and leave zero alone in order to use - -- GNAT.Heap_Sort_G. - - Edges_Len := 2 * NK + 1; - - if Edges = No_Table then - Edges := Allocate (Edges_Len, Edge_Size); - end if; - - if Vertices = No_Table then - Vertices := Allocate (NV, Vertex_Size); - end if; - - for J in 0 .. NV - 1 loop - Set_Vertices (J, (No_Vertex, No_Vertex - 1)); - end loop; - - -- For each w, X = f1 (w) and Y = f2 (w) - - for J in 0 .. NK - 1 loop - Key := Get_Key (J); - Key.Edge := No_Edge; - Set_Key (J, Key); - - X := Sum (WT.Table (Reduced (J)), T1, Opt); - Y := Sum (WT.Table (Reduced (J)), T2, Opt); - - -- Discard T1 and T2 as soon as we discover a self loop - - if X = Y then - Not_Acyclic := True; - exit; - end if; - - -- We store (X, Y) and (Y, X) to ease assignment step - - Set_Edges (2 * J + 1, (X, Y, J)); - Set_Edges (2 * J + 2, (Y, X, J)); - end loop; - - -- Return an empty graph when self loop detected - - if Not_Acyclic then - Edges_Len := 0; - - else - if Verbose then - Put_Edges (Output, "Unsorted Edge Table"); - Put_Int_Matrix (Output, "Function Table 1", T1, - T1_Len, T2_Len); - Put_Int_Matrix (Output, "Function Table 2", T2, - T1_Len, T2_Len); - end if; - - -- Enforce consistency between edges and keys. Construct Vertices and - -- compute the list of neighbors of a vertex First .. Last as Edges - -- is sorted by X and then Y. To compute the neighbor list, sort the - -- edges. - - Sorting.Sort (Edges_Len - 1); - - if Verbose then - Put_Edges (Output, "Sorted Edge Table"); - Put_Int_Matrix (Output, "Function Table 1", T1, - T1_Len, T2_Len); - Put_Int_Matrix (Output, "Function Table 2", T2, - T1_Len, T2_Len); - end if; - - -- Edges valid range is 1 .. 2 * NK - - for E in 1 .. Edges_Len - 1 loop - Edge := Get_Edges (E); - Key := Get_Key (Edge.Key); - - if Key.Edge = No_Edge then - Key.Edge := E; - Set_Key (Edge.Key, Key); - end if; - - Vertex := Get_Vertices (Edge.X); - - if Vertex.First = No_Edge then - Vertex.First := E; - end if; - - Vertex.Last := E; - Set_Vertices (Edge.X, Vertex); - end loop; - - if Verbose then - Put_Reduced_Keys (Output, "Key Table"); - Put_Edges (Output, "Edge Table"); - Put_Vertex_Table (Output, "Vertex Table"); - end if; - end if; - end Compute_Edges_And_Vertices; - - ------------ - -- Define -- - ------------ - - procedure Define - (Name : Table_Name; - Item_Size : out Natural; - Length_1 : out Natural; - Length_2 : out Natural) - is - begin - case Name is - when Character_Position => - Item_Size := 8; - Length_1 := Char_Pos_Set_Len; - Length_2 := 0; - - when Used_Character_Set => - Item_Size := 8; - Length_1 := 256; - Length_2 := 0; - - when Function_Table_1 - | Function_Table_2 - => - Item_Size := Type_Size (NV); - Length_1 := T1_Len; - Length_2 := T2_Len; - - when Graph_Table => - Item_Size := Type_Size (NK); - Length_1 := NV; - Length_2 := 0; - end case; - end Define; - -------------- -- Finalize -- -------------- procedure Finalize is begin - if Verbose then - Put (Output, "Finalize"); - New_Line (Output); - end if; - - -- Deallocate all the WT components (both initial and reduced ones) to - -- avoid memory leaks. - - for W in 0 .. WT.Last loop - - -- Note: WT.Table (NK) is a temporary variable, do not free it since - -- this would cause a double free. - - if W /= NK then - Free_Word (WT.Table (W)); - end if; - end loop; - - WT.Release; - IT.Release; - - -- Reset all variables for next usage - - Keys := No_Table; - - Char_Pos_Set := No_Table; - Char_Pos_Set_Len := 0; - - Used_Char_Set := No_Table; - Used_Char_Set_Len := 0; - - T1 := No_Table; - T2 := No_Table; - - T1_Len := 0; - T2_Len := 0; - - G := No_Table; - G_Len := 0; - - Edges := No_Table; - Edges_Len := 0; - - Vertices := No_Table; - NV := 0; - NK := 0; - Max_Key_Len := 0; - Min_Key_Len := 0; + SPHG.Finalize; end Finalize; - ---------------------------- - -- Generate_Mapping_Table -- - ---------------------------- - - procedure Generate_Mapping_Table - (Tab : Integer; - L1 : Natural; - L2 : Natural; - Seed : in out Natural) - is - begin - for J in 0 .. L1 - 1 loop - for K in 0 .. L2 - 1 loop - Random (Seed); - Set_Table (Tab, J, K, Seed mod NV); - end loop; - end loop; - end Generate_Mapping_Table; - - ----------------------------- - -- Generate_Mapping_Tables -- - ----------------------------- - - procedure Generate_Mapping_Tables - (Opt : Optimization; - Seed : in out Natural) - is - begin - -- If T1 and T2 are already allocated no need to do it twice. Reuse them - -- as their size has not changed. - - if T1 = No_Table and then T2 = No_Table then - declare - Used_Char_Last : Natural := 0; - Used_Char : Natural; - - begin - if Opt = CPU_Time then - for P in reverse Character'Range loop - Used_Char := Get_Used_Char (P); - if Used_Char /= 0 then - Used_Char_Last := Used_Char; - exit; - end if; - end loop; - end if; - - T1_Len := Char_Pos_Set_Len; - T2_Len := Used_Char_Last + 1; - T1 := Allocate (T1_Len * T2_Len); - T2 := Allocate (T1_Len * T2_Len); - end; - end if; - - Generate_Mapping_Table (T1, T1_Len, T2_Len, Seed); - Generate_Mapping_Table (T2, T1_Len, T2_Len, Seed); - - if Verbose then - Put_Used_Char_Set (Output, "Used Character Set"); - Put_Int_Matrix (Output, "Function Table 1", T1, - T1_Len, T2_Len); - Put_Int_Matrix (Output, "Function Table 2", T2, - T1_Len, T2_Len); - end if; - end Generate_Mapping_Tables; - - ------------------ - -- Get_Char_Pos -- - ------------------ - - function Get_Char_Pos (P : Natural) return Natural is - N : constant Natural := Char_Pos_Set + P; - begin - return IT.Table (N); - end Get_Char_Pos; - - --------------- - -- Get_Edges -- - --------------- - - function Get_Edges (F : Natural) return Edge_Type is - N : constant Natural := Edges + (F * Edge_Size); - E : Edge_Type; - begin - E.X := IT.Table (N); - E.Y := IT.Table (N + 1); - E.Key := IT.Table (N + 2); - return E; - end Get_Edges; - - --------------- - -- Get_Graph -- - --------------- - - function Get_Graph (N : Natural) return Integer is - begin - return IT.Table (G + N); - end Get_Graph; - - ------------- - -- Get_Key -- - ------------- - - function Get_Key (N : Key_Id) return Key_Type is - K : Key_Type; - begin - K.Edge := IT.Table (Keys + N); - return K; - end Get_Key; - - --------------- - -- Get_Table -- - --------------- - - function Get_Table (T : Integer; X, Y : Natural) return Natural is - N : constant Natural := T + (Y * T1_Len) + X; - begin - return IT.Table (N); - end Get_Table; - - ------------------- - -- Get_Used_Char -- - ------------------- - - function Get_Used_Char (C : Character) return Natural is - N : constant Natural := Used_Char_Set + Character'Pos (C); - begin - return IT.Table (N); - end Get_Used_Char; - - ------------------ - -- Get_Vertices -- - ------------------ - - function Get_Vertices (F : Natural) return Vertex_Type is - N : constant Natural := Vertices + (F * Vertex_Size); - V : Vertex_Type; - begin - V.First := IT.Table (N); - V.Last := IT.Table (N + 1); - return V; - end Get_Vertices; - ----------- -- Image -- ----------- @@ -1164,15 +227,6 @@ package body GNAT.Perfect_Hash_Generators is end; end Image; - ------------- - -- Initial -- - ------------- - - function Initial (K : Key_Id) return Word_Id is - begin - return K; - end Initial; - ---------------- -- Initialize -- ---------------- @@ -1183,87 +237,11 @@ package body GNAT.Perfect_Hash_Generators is Optim : Optimization := Memory_Space; Tries : Positive := Default_Tries) is - begin - if Verbose then - Put (Output, "Initialize"); - New_Line (Output); - end if; - - -- Deallocate the part of the table concerning the reduced words. - -- Initial words are already present in the table. We may have reduced - -- words already there because a previous computation failed. We are - -- currently retrying and the reduced words have to be deallocated. - - for W in Reduced (0) .. WT.Last loop - Free_Word (WT.Table (W)); - end loop; - - IT.Init; - - -- Initialize of computation variables - - Keys := No_Table; + V : constant Positive := Positive (Float (NK) * K_To_V); - Char_Pos_Set := No_Table; - Char_Pos_Set_Len := 0; - - Used_Char_Set := No_Table; - Used_Char_Set_Len := 0; - - T1 := No_Table; - T2 := No_Table; - - T1_Len := 0; - T2_Len := 0; - - G := No_Table; - G_Len := 0; - - Edges := No_Table; - Edges_Len := 0; - - Vertices := No_Table; - NV := 0; - - S := Seed; - K2V := K_To_V; - Opt := Optim; - NT := Tries; - - if K2V <= 2.0 then - raise Program_Error with "K to V ratio cannot be lower than 2.0"; - end if; - - -- Do not accept a value of K2V too close to 2.0 such that once - -- rounded up, NV = 2 * NK because the algorithm would not converge. - - NV := Natural (Float (NK) * K2V); - if NV <= 2 * NK then - NV := 2 * NK + 1; - end if; - - Keys := Allocate (NK); - - -- Resize initial words to have all of them at the same size - -- (so the size of the largest one). - - for K in 0 .. NK - 1 loop - Resize_Word (WT.Table (Initial (K)), Max_Key_Len); - end loop; - - -- Allocated the table to store the reduced words. As WT is a - -- GNAT.Table (using C memory management), pointers have to be - -- explicitly initialized to null. - - WT.Set_Last (Reduced (NK - 1)); - - -- Note: Reduced (0) = NK + 1 - - WT.Table (NK) := null; - - for W in 0 .. NK - 1 loop - WT.Table (Reduced (W)) := null; - end loop; + begin + Opt := Optim; + SPHG.Initialize (Seed, V, SPHG.Optimization (Optim), Tries); end Initialize; ------------ @@ -1271,162 +249,21 @@ package body GNAT.Perfect_Hash_Generators is ------------ procedure Insert (Value : String) is - Len : constant Natural := Value'Length; - - begin - if Verbose then - Put (Output, "Inserting """ & Value & """"); - New_Line (Output); - end if; - - for J in Value'Range loop - pragma Assert (Value (J) /= ASCII.NUL); - null; - end loop; - - WT.Set_Last (NK); - WT.Table (NK) := New_Word (Value); - NK := NK + 1; - - if Max_Key_Len < Len then - Max_Key_Len := Len; - end if; - - if Min_Key_Len = 0 or else Len < Min_Key_Len then - Min_Key_Len := Len; - end if; - end Insert; - - -------------- - -- New_Line -- - -------------- - - procedure New_Line (File : File_Descriptor) is - begin - if Write (File, EOL'Address, 1) /= 1 then - raise Program_Error; - end if; - end New_Line; - - -------------- - -- New_Word -- - -------------- - - function New_Word (S : String) return Word_Type is - begin - return new String'(S); - end New_Word; - - ------------------------------ - -- Parse_Position_Selection -- - ------------------------------ - - procedure Parse_Position_Selection (Argument : String) is - N : Natural := Argument'First; - L : constant Natural := Argument'Last; - M : constant Natural := Max_Key_Len; - - T : array (1 .. M) of Boolean := (others => False); - - function Parse_Index return Natural; - -- Parse argument starting at index N to find an index - - ----------------- - -- Parse_Index -- - ----------------- - - function Parse_Index return Natural is - C : Character := Argument (N); - V : Natural := 0; - - begin - if C = '$' then - N := N + 1; - return M; - end if; - - if C not in '0' .. '9' then - raise Program_Error with "cannot read position argument"; - end if; - - while C in '0' .. '9' loop - V := V * 10 + (Character'Pos (C) - Character'Pos ('0')); - N := N + 1; - exit when L < N; - C := Argument (N); - end loop; - - return V; - end Parse_Index; - - -- Start of processing for Parse_Position_Selection - - begin - -- Empty specification means all the positions - - if L < N then - Char_Pos_Set_Len := M; - Char_Pos_Set := Allocate (Char_Pos_Set_Len); - - for C in 0 .. Char_Pos_Set_Len - 1 loop - Set_Char_Pos (C, C + 1); - end loop; - - else - loop - declare - First, Last : Natural; - - begin - First := Parse_Index; - Last := First; - - -- Detect a range - - if N <= L and then Argument (N) = '-' then - N := N + 1; - Last := Parse_Index; - end if; - - -- Include the positions in the selection - - for J in First .. Last loop - T (J) := True; - end loop; - end; - - exit when L < N; - - if Argument (N) /= ',' then - raise Program_Error with "cannot read position argument"; - end if; - - N := N + 1; - end loop; - - -- Compute position selection length - - N := 0; - for J in T'Range loop - if T (J) then - N := N + 1; - end if; - end loop; - - -- Fill position selection + begin + NK := NK + 1; + SPHG.Insert (Value); + end Insert; - Char_Pos_Set_Len := N; - Char_Pos_Set := Allocate (Char_Pos_Set_Len); + -------------- + -- New_Line -- + -------------- - N := 0; - for J in T'Range loop - if T (J) then - Set_Char_Pos (N, J); - N := N + 1; - end if; - end loop; + procedure New_Line (File : File_Descriptor) is + begin + if Write (File, EOL'Address, 1) /= 1 then + raise Program_Error; end if; - end Parse_Position_Selection; + end New_Line; ------------- -- Produce -- @@ -1438,6 +275,9 @@ package body GNAT.Perfect_Hash_Generators is is File : File_Descriptor := Standout; + Siz, L1, L2 : Natural; + -- For calls to Define + Status : Boolean; -- For call to Close @@ -1447,8 +287,8 @@ package body GNAT.Perfect_Hash_Generators is function Range_Img (F, L : Natural; T : String := "") return String; -- Return string "[T range ]F .. L" - function Type_Img (L : Natural) return String; - -- Return the larger unsigned type T such that T'Last < L + function Type_Img (Siz : Positive) return String; + -- Return the name of the unsigned type of size S --------------- -- Array_Img -- @@ -1510,8 +350,8 @@ package body GNAT.Perfect_Hash_Generators is -- Type_Img -- -------------- - function Type_Img (L : Natural) return String is - S : constant String := Image (Type_Size (L)); + function Type_Img (Siz : Positive) return String is + S : constant String := Image (Siz); U : String := "Unsigned_ "; N : Natural := 9; @@ -1524,8 +364,6 @@ package body GNAT.Perfect_Hash_Generators is return U (1 .. N); end Type_Img; - F : Natural; - L : Natural; P : Natural; FName : String := Ada_File_Base_Name (Pkg_Name) & ".ads"; @@ -1535,13 +373,6 @@ package body GNAT.Perfect_Hash_Generators is -- Start of processing for Produce begin - - if Verbose and then not Use_Stdout then - Put (Output, - "Producing " & Ada.Directories.Current_Directory & "/" & FName); - New_Line (Output); - end if; - if not Use_Stdout then File := Create_File (FName, Binary); @@ -1592,75 +423,89 @@ package body GNAT.Perfect_Hash_Generators is New_Line (File); if Opt = CPU_Time then - Put (File, Array_Img ("C", Type_Img (256), "Character")); - New_Line (File); + -- The format of this table is fixed - F := Character'Pos (Character'First); - L := Character'Pos (Character'Last); + Define (Used_Character_Set, Siz, L1, L2); + pragma Assert (L1 = 256 and then L2 = 0); + + Put (File, Array_Img ("C", Type_Img (Siz), "Character")); + New_Line (File); - for J in Character'Range loop - P := Get_Used_Char (J); - Put (File, Image (P), 1, 0, 1, F, L, Character'Pos (J)); + for J in 0 .. 255 loop + P := Value (Used_Character_Set, J); + Put (File, Image (P), 1, 0, 1, 0, 255, J); end loop; New_Line (File); end if; - F := 0; - L := Char_Pos_Set_Len - 1; + Define (Character_Position, Siz, L1, L2); + pragma Assert (Siz = 31 and then L2 = 0); - Put (File, Array_Img ("P", "Natural", Range_Img (F, L))); + Put (File, Array_Img ("P", "Natural", Range_Img (0, L1 - 1))); New_Line (File); - for J in F .. L loop - Put (File, Image (Get_Char_Pos (J)), 1, 0, 1, F, L, J); + for J in 0 .. L1 - 1 loop + P := Value (Character_Position, J); + Put (File, Image (P), 1, 0, 1, 0, L1 - 1, J); end loop; New_Line (File); + Define (Function_Table_1, Siz, L1, L2); + case Opt is when CPU_Time => Put_Int_Matrix (File, - Array_Img ("T1", Type_Img (NV), - Range_Img (0, T1_Len - 1), - Range_Img (0, T2_Len - 1, Type_Img (256))), - T1, T1_Len, T2_Len); + Array_Img ("T1", Type_Img (Siz), + Range_Img (0, L1 - 1), + Range_Img (0, L2 - 1, Type_Img (8))), + Function_Table_1, L1, L2); when Memory_Space => Put_Int_Matrix (File, - Array_Img ("T1", Type_Img (NV), - Range_Img (0, T1_Len - 1)), - T1, T1_Len, 0); + Array_Img ("T1", Type_Img (Siz), + Range_Img (0, L1 - 1)), + Function_Table_1, L1, 0); end case; New_Line (File); + Define (Function_Table_2, Siz, L1, L2); + case Opt is when CPU_Time => Put_Int_Matrix (File, - Array_Img ("T2", Type_Img (NV), - Range_Img (0, T1_Len - 1), - Range_Img (0, T2_Len - 1, Type_Img (256))), - T2, T1_Len, T2_Len); + Array_Img ("T2", Type_Img (Siz), + Range_Img (0, L1 - 1), + Range_Img (0, L2 - 1, Type_Img (8))), + Function_Table_2, L1, L2); when Memory_Space => Put_Int_Matrix (File, - Array_Img ("T2", Type_Img (NV), - Range_Img (0, T1_Len - 1)), - T2, T1_Len, 0); + Array_Img ("T2", Type_Img (Siz), + Range_Img (0, L1 - 1)), + Function_Table_2, L1, 0); end case; New_Line (File); - Put_Int_Vector - (File, - Array_Img ("G", Type_Img (NK), - Range_Img (0, G_Len - 1)), - G, G_Len); + Define (Graph_Table, Siz, L1, L2); + pragma Assert (L2 = 0); + + Put (File, Array_Img ("G", Type_Img (Siz), + Range_Img (0, L1 - 1))); + New_Line (File); + + for J in 0 .. L1 - 1 loop + P := Value (Graph_Table, J); + Put (File, Image (P), 1, 0, 1, 0, L1 - 1, J); + end loop; + New_Line (File); Put (File, " function Hash (S : String) return Natural is"); @@ -1676,7 +521,7 @@ package body GNAT.Perfect_Hash_Generators is case Opt is when CPU_Time => - Put (File, Type_Img (256)); + Put (File, Type_Img (8)); when Memory_Space => Put (File, "Natural"); @@ -1717,7 +562,7 @@ package body GNAT.Perfect_Hash_Generators is end if; Put (File, ") mod "); - Put (File, Image (NV)); + Put (File, Image (L1)); Put (File, ";"); New_Line (File); @@ -1734,7 +579,7 @@ package body GNAT.Perfect_Hash_Generators is end if; Put (File, ") mod "); - Put (File, Image (NV)); + Put (File, Image (L1)); Put (File, ";"); New_Line (File); @@ -1874,54 +719,6 @@ package body GNAT.Perfect_Hash_Generators is end if; end Put; - --------------- - -- Put_Edges -- - --------------- - - procedure Put_Edges (File : File_Descriptor; Title : String) is - E : Edge_Type; - F1 : constant Natural := 1; - L1 : constant Natural := Edges_Len - 1; - M : constant Natural := Max / 5; - - begin - Put (File, Title); - New_Line (File); - - -- Edges valid range is 1 .. Edge_Len - 1 - - for J in F1 .. L1 loop - E := Get_Edges (J); - Put (File, Image (J, M), F1, L1, J, 1, 4, 1); - Put (File, Image (E.X, M), F1, L1, J, 1, 4, 2); - Put (File, Image (E.Y, M), F1, L1, J, 1, 4, 3); - Put (File, Image (E.Key, M), F1, L1, J, 1, 4, 4); - end loop; - end Put_Edges; - - ---------------------- - -- Put_Initial_Keys -- - ---------------------- - - procedure Put_Initial_Keys (File : File_Descriptor; Title : String) is - F1 : constant Natural := 0; - L1 : constant Natural := NK - 1; - M : constant Natural := Max / 5; - K : Key_Type; - - begin - Put (File, Title); - New_Line (File); - - for J in F1 .. L1 loop - K := Get_Key (J); - Put (File, Image (J, M), F1, L1, J, 1, 3, 1); - Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2); - Put (File, Trim_Trailing_Nuls (WT.Table (Initial (J)).all), - F1, L1, J, 1, 3, 3); - end loop; - end Put_Initial_Keys; - -------------------- -- Put_Int_Matrix -- -------------------- @@ -1929,7 +726,7 @@ package body GNAT.Perfect_Hash_Generators is procedure Put_Int_Matrix (File : File_Descriptor; Title : String; - Table : Integer; + Table : Table_Name; Len_1 : Natural; Len_2 : Natural) is @@ -1945,665 +742,18 @@ package body GNAT.Perfect_Hash_Generators is if Len_2 = 0 then for J in F1 .. L1 loop - Ix := IT.Table (Table + J); + Ix := Value (Table, J, 0); Put (File, Image (Ix), 1, 0, 1, F1, L1, J); end loop; else for J in F1 .. L1 loop for K in F2 .. L2 loop - Ix := IT.Table (Table + J + K * Len_1); + Ix := Value (Table, J, K); Put (File, Image (Ix), F1, L1, J, F2, L2, K); end loop; end loop; end if; end Put_Int_Matrix; - -------------------- - -- Put_Int_Vector -- - -------------------- - - procedure Put_Int_Vector - (File : File_Descriptor; - Title : String; - Vector : Integer; - Length : Natural) - is - F2 : constant Natural := 0; - L2 : constant Natural := Length - 1; - - begin - Put (File, Title); - New_Line (File); - - for J in F2 .. L2 loop - Put (File, Image (IT.Table (Vector + J)), 1, 0, 1, F2, L2, J); - end loop; - end Put_Int_Vector; - - ---------------------- - -- Put_Reduced_Keys -- - ---------------------- - - procedure Put_Reduced_Keys (File : File_Descriptor; Title : String) is - F1 : constant Natural := 0; - L1 : constant Natural := NK - 1; - M : constant Natural := Max / 5; - K : Key_Type; - - begin - Put (File, Title); - New_Line (File); - - for J in F1 .. L1 loop - K := Get_Key (J); - Put (File, Image (J, M), F1, L1, J, 1, 3, 1); - Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2); - Put (File, Trim_Trailing_Nuls (WT.Table (Reduced (J)).all), - F1, L1, J, 1, 3, 3); - end loop; - end Put_Reduced_Keys; - - ----------------------- - -- Put_Used_Char_Set -- - ----------------------- - - procedure Put_Used_Char_Set (File : File_Descriptor; Title : String) is - F : constant Natural := Character'Pos (Character'First); - L : constant Natural := Character'Pos (Character'Last); - - begin - Put (File, Title); - New_Line (File); - - for J in Character'Range loop - Put - (File, Image (Get_Used_Char (J)), 1, 0, 1, F, L, Character'Pos (J)); - end loop; - end Put_Used_Char_Set; - - ---------------------- - -- Put_Vertex_Table -- - ---------------------- - - procedure Put_Vertex_Table (File : File_Descriptor; Title : String) is - F1 : constant Natural := 0; - L1 : constant Natural := NV - 1; - M : constant Natural := Max / 4; - V : Vertex_Type; - - begin - Put (File, Title); - New_Line (File); - - for J in F1 .. L1 loop - V := Get_Vertices (J); - Put (File, Image (J, M), F1, L1, J, 1, 3, 1); - Put (File, Image (V.First, M), F1, L1, J, 1, 3, 2); - Put (File, Image (V.Last, M), F1, L1, J, 1, 3, 3); - end loop; - end Put_Vertex_Table; - - ------------ - -- Random -- - ------------ - - procedure Random (Seed : in out Natural) is - - -- Park & Miller Standard Minimal using Schrage's algorithm to avoid - -- overflow: Xn+1 = 16807 * Xn mod (2 ** 31 - 1) - - R : Natural; - Q : Natural; - X : Integer; - - begin - R := Seed mod 127773; - Q := Seed / 127773; - X := 16807 * R - 2836 * Q; - - Seed := (if X < 0 then X + 2147483647 else X); - end Random; - - ------------- - -- Reduced -- - ------------- - - function Reduced (K : Key_Id) return Word_Id is - begin - return K + NK + 1; - end Reduced; - - ----------------- - -- Resize_Word -- - ----------------- - - procedure Resize_Word (W : in out Word_Type; Len : Natural) is - S1 : constant String := W.all; - S2 : String (1 .. Len) := (others => ASCII.NUL); - L : constant Natural := S1'Length; - begin - if L /= Len then - Free_Word (W); - S2 (1 .. L) := S1; - W := New_Word (S2); - end if; - end Resize_Word; - - -------------------------- - -- Select_Char_Position -- - -------------------------- - - procedure Select_Char_Position is - - type Vertex_Table_Type is array (Natural range <>) of Vertex_Type; - - procedure Build_Identical_Keys_Sets - (Table : in out Vertex_Table_Type; - Last : in out Natural; - Pos : Natural); - -- Build a list of keys subsets that are identical with the current - -- position selection plus Pos. Once this routine is called, reduced - -- words are sorted by subsets and each item (First, Last) in Sets - -- defines the range of identical keys. - -- Need comment saying exactly what Last is ??? - - function Count_Different_Keys - (Table : Vertex_Table_Type; - Last : Natural; - Pos : Natural) return Natural; - -- For each subset in Sets, count the number of different keys if we add - -- Pos to the current position selection. - - Sel_Position : IT.Table_Type (1 .. Max_Key_Len); - Last_Sel_Pos : Natural := 0; - Max_Sel_Pos : Natural := 0; - - ------------------------------- - -- Build_Identical_Keys_Sets -- - ------------------------------- - - procedure Build_Identical_Keys_Sets - (Table : in out Vertex_Table_Type; - Last : in out Natural; - Pos : Natural) - is - S : constant Vertex_Table_Type := Table (Table'First .. Last); - C : constant Natural := Pos; - -- Shortcuts (why are these not renames ???) - - F : Integer; - L : Integer; - -- First and last words of a subset - - Offset : Natural; - -- GNAT.Heap_Sort assumes that the first array index is 1. Offset - -- defines the translation to operate. - - function Lt (L, R : Natural) return Boolean; - procedure Move (From : Natural; To : Natural); - -- Subprograms needed by GNAT.Heap_Sort_G - - -------- - -- Lt -- - -------- - - function Lt (L, R : Natural) return Boolean is - C : constant Natural := Pos; - Left : Natural; - Right : Natural; - - begin - if L = 0 then - Left := NK; - Right := Offset + R; - elsif R = 0 then - Left := Offset + L; - Right := NK; - else - Left := Offset + L; - Right := Offset + R; - end if; - - return WT.Table (Left)(C) < WT.Table (Right)(C); - end Lt; - - ---------- - -- Move -- - ---------- - - procedure Move (From : Natural; To : Natural) is - Target, Source : Natural; - - begin - if From = 0 then - Source := NK; - Target := Offset + To; - elsif To = 0 then - Source := Offset + From; - Target := NK; - else - Source := Offset + From; - Target := Offset + To; - end if; - - WT.Table (Target) := WT.Table (Source); - WT.Table (Source) := null; - end Move; - - package Sorting is new GNAT.Heap_Sort_G (Move, Lt); - - -- Start of processing for Build_Identical_Key_Sets - - begin - Last := 0; - - -- For each subset in S, extract the new subsets we have by adding C - -- in the position selection. - - for J in S'Range loop - pragma Annotate (CodePeer, Modified, S (J)); - - if S (J).First = S (J).Last then - F := S (J).First; - L := S (J).Last; - Last := Last + 1; - Table (Last) := (F, L); - - else - Offset := Reduced (S (J).First) - 1; - Sorting.Sort (S (J).Last - S (J).First + 1); - - F := S (J).First; - L := F; - for N in S (J).First .. S (J).Last loop - - -- For the last item, close the last subset - - if N = S (J).Last then - Last := Last + 1; - Table (Last) := (F, N); - - -- Two contiguous words are identical when they have the - -- same Cth character. - - elsif WT.Table (Reduced (N))(C) = - WT.Table (Reduced (N + 1))(C) - then - L := N + 1; - - -- Find a new subset of identical keys. Store the current - -- one and create a new subset. - - else - Last := Last + 1; - Table (Last) := (F, L); - F := N + 1; - L := F; - end if; - end loop; - end if; - end loop; - end Build_Identical_Keys_Sets; - - -------------------------- - -- Count_Different_Keys -- - -------------------------- - - function Count_Different_Keys - (Table : Vertex_Table_Type; - Last : Natural; - Pos : Natural) return Natural - is - N : array (Character) of Natural; - C : Character; - T : Natural := 0; - - begin - -- For each subset, count the number of words that are still - -- different when we include Pos in the position selection. Only - -- focus on this position as the other positions already produce - -- identical keys. - - for S in 1 .. Last loop - - -- Count the occurrences of the different characters - - N := (others => 0); - for K in Table (S).First .. Table (S).Last loop - C := WT.Table (Reduced (K))(Pos); - N (C) := N (C) + 1; - end loop; - - -- Update the number of different keys. Each character used - -- denotes a different key. - - for J in N'Range loop - if N (J) > 0 then - T := T + 1; - end if; - end loop; - end loop; - - return T; - end Count_Different_Keys; - - -- Start of processing for Select_Char_Position - - begin - -- Initialize the reduced words set - - for K in 0 .. NK - 1 loop - WT.Table (Reduced (K)) := New_Word (WT.Table (Initial (K)).all); - end loop; - - declare - Differences : Natural; - Max_Differences : Natural := 0; - Old_Differences : Natural; - Max_Diff_Sel_Pos : Natural := 0; -- init to kill warning - Max_Diff_Sel_Pos_Idx : Natural := 0; -- init to kill warning - Same_Keys_Sets_Table : Vertex_Table_Type (1 .. NK); - Same_Keys_Sets_Last : Natural := 1; - - begin - for C in Sel_Position'Range loop - Sel_Position (C) := C; - end loop; - - Same_Keys_Sets_Table (1) := (0, NK - 1); - - loop - -- Preserve maximum number of different keys and check later on - -- that this value is strictly incrementing. Otherwise, it means - -- that two keys are strictly identical. - - Old_Differences := Max_Differences; - - -- The first position should not exceed the minimum key length. - -- Otherwise, we may end up with an empty word once reduced. - - Max_Sel_Pos := - (if Last_Sel_Pos = 0 then Min_Key_Len else Max_Key_Len); - - -- Find which position increases more the number of differences - - for J in Last_Sel_Pos + 1 .. Max_Sel_Pos loop - Differences := Count_Different_Keys - (Same_Keys_Sets_Table, - Same_Keys_Sets_Last, - Sel_Position (J)); - - if Verbose then - Put (Output, - "Selecting position" & Sel_Position (J)'Img & - " results in" & Differences'Img & - " differences"); - New_Line (Output); - end if; - - if Differences > Max_Differences then - Max_Differences := Differences; - Max_Diff_Sel_Pos := Sel_Position (J); - Max_Diff_Sel_Pos_Idx := J; - end if; - end loop; - - if Old_Differences = Max_Differences then - raise Program_Error with "some keys are identical"; - end if; - - -- Insert selected position and sort Sel_Position table - - Last_Sel_Pos := Last_Sel_Pos + 1; - Sel_Position (Last_Sel_Pos + 1 .. Max_Diff_Sel_Pos_Idx) := - Sel_Position (Last_Sel_Pos .. Max_Diff_Sel_Pos_Idx - 1); - Sel_Position (Last_Sel_Pos) := Max_Diff_Sel_Pos; - - for P in 1 .. Last_Sel_Pos - 1 loop - if Max_Diff_Sel_Pos < Sel_Position (P) then - pragma Annotate - (CodePeer, False_Positive, - "test always false", "false positive?"); - - Sel_Position (P + 1 .. Last_Sel_Pos) := - Sel_Position (P .. Last_Sel_Pos - 1); - Sel_Position (P) := Max_Diff_Sel_Pos; - exit; - end if; - end loop; - - exit when Max_Differences = NK; - - Build_Identical_Keys_Sets - (Same_Keys_Sets_Table, - Same_Keys_Sets_Last, - Max_Diff_Sel_Pos); - - if Verbose then - Put (Output, - "Selecting position" & Max_Diff_Sel_Pos'Img & - " results in" & Max_Differences'Img & - " differences"); - New_Line (Output); - Put (Output, "--"); - New_Line (Output); - for J in 1 .. Same_Keys_Sets_Last loop - for K in - Same_Keys_Sets_Table (J).First .. - Same_Keys_Sets_Table (J).Last - loop - Put (Output, - Trim_Trailing_Nuls (WT.Table (Reduced (K)).all)); - New_Line (Output); - end loop; - Put (Output, "--"); - New_Line (Output); - end loop; - end if; - end loop; - end; - - Char_Pos_Set_Len := Last_Sel_Pos; - Char_Pos_Set := Allocate (Char_Pos_Set_Len); - - for C in 1 .. Last_Sel_Pos loop - Set_Char_Pos (C - 1, Sel_Position (C)); - end loop; - end Select_Char_Position; - - -------------------------- - -- Select_Character_Set -- - -------------------------- - - procedure Select_Character_Set is - Last : Natural := 0; - Used : array (Character) of Boolean := (others => False); - Char : Character; - - begin - for J in 0 .. NK - 1 loop - for K in 0 .. Char_Pos_Set_Len - 1 loop - Char := WT.Table (Initial (J))(Get_Char_Pos (K)); - exit when Char = ASCII.NUL; - Used (Char) := True; - end loop; - end loop; - - Used_Char_Set_Len := 256; - Used_Char_Set := Allocate (Used_Char_Set_Len); - - for J in Used'Range loop - if Used (J) then - Set_Used_Char (J, Last); - Last := Last + 1; - else - Set_Used_Char (J, 0); - end if; - end loop; - end Select_Character_Set; - - ------------------ - -- Set_Char_Pos -- - ------------------ - - procedure Set_Char_Pos (P : Natural; Item : Natural) is - N : constant Natural := Char_Pos_Set + P; - begin - IT.Table (N) := Item; - end Set_Char_Pos; - - --------------- - -- Set_Edges -- - --------------- - - procedure Set_Edges (F : Natural; Item : Edge_Type) is - N : constant Natural := Edges + (F * Edge_Size); - begin - IT.Table (N) := Item.X; - IT.Table (N + 1) := Item.Y; - IT.Table (N + 2) := Item.Key; - end Set_Edges; - - --------------- - -- Set_Graph -- - --------------- - - procedure Set_Graph (N : Natural; Item : Integer) is - begin - IT.Table (G + N) := Item; - end Set_Graph; - - ------------- - -- Set_Key -- - ------------- - - procedure Set_Key (N : Key_Id; Item : Key_Type) is - begin - IT.Table (Keys + N) := Item.Edge; - end Set_Key; - - --------------- - -- Set_Table -- - --------------- - - procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural) is - N : constant Natural := T + ((Y * T1_Len) + X); - begin - IT.Table (N) := Item; - end Set_Table; - - ------------------- - -- Set_Used_Char -- - ------------------- - - procedure Set_Used_Char (C : Character; Item : Natural) is - N : constant Natural := Used_Char_Set + Character'Pos (C); - begin - IT.Table (N) := Item; - end Set_Used_Char; - - ------------------ - -- Set_Vertices -- - ------------------ - - procedure Set_Vertices (F : Natural; Item : Vertex_Type) is - N : constant Natural := Vertices + (F * Vertex_Size); - begin - IT.Table (N) := Item.First; - IT.Table (N + 1) := Item.Last; - end Set_Vertices; - - --------- - -- Sum -- - --------- - - function Sum - (Word : Word_Type; - Table : Table_Id; - Opt : Optimization) return Natural - is - S : Natural := 0; - R : Natural; - - begin - case Opt is - when CPU_Time => - for J in 0 .. T1_Len - 1 loop - exit when Word (J + 1) = ASCII.NUL; - R := Get_Table (Table, J, Get_Used_Char (Word (J + 1))); - pragma Assert (NV /= 0); - S := (S + R) mod NV; - end loop; - - when Memory_Space => - for J in 0 .. T1_Len - 1 loop - exit when Word (J + 1) = ASCII.NUL; - R := Get_Table (Table, J, 0); - pragma Assert (NV /= 0); - S := (S + R * Character'Pos (Word (J + 1))) mod NV; - end loop; - end case; - - return S; - end Sum; - - ------------------------ - -- Trim_Trailing_Nuls -- - ------------------------ - - function Trim_Trailing_Nuls (Str : String) return String is - begin - for J in reverse Str'Range loop - if Str (J) /= ASCII.NUL then - return Str (Str'First .. J); - end if; - end loop; - - return Str; - end Trim_Trailing_Nuls; - - --------------- - -- Type_Size -- - --------------- - - function Type_Size (L : Natural) return Natural is - begin - if L <= 2 ** 8 then - return 8; - elsif L <= 2 ** 16 then - return 16; - else - return 32; - end if; - end Type_Size; - - ----------- - -- Value -- - ----------- - - function Value - (Name : Table_Name; - J : Natural; - K : Natural := 0) return Natural - is - begin - case Name is - when Character_Position => - return Get_Char_Pos (J); - - when Used_Character_Set => - return Get_Used_Char (Character'Val (J)); - - when Function_Table_1 => - return Get_Table (T1, J, K); - - when Function_Table_2 => - return Get_Table (T2, J, K); - - when Graph_Table => - return Get_Graph (J); - end case; - end Value; - end GNAT.Perfect_Hash_Generators; diff --git a/gcc/ada/libgnat/g-pehage.ads b/gcc/ada/libgnat/g-pehage.ads index 08c9af1c0c57..41913cbc97f5 100644 --- a/gcc/ada/libgnat/g-pehage.ads +++ b/gcc/ada/libgnat/g-pehage.ads @@ -64,8 +64,12 @@ -- < h (w2). These hashing functions are convenient for use with realtime -- applications. +with System.Perfect_Hash_Generators; + package GNAT.Perfect_Hash_Generators is + package SPHG renames System.Perfect_Hash_Generators; + Default_K_To_V : constant Float := 2.05; -- Default ratio for the algorithm. When K is the number of keys, V = -- (K_To_V) * K is the size of the main table of the hash function. To @@ -83,12 +87,12 @@ package GNAT.Perfect_Hash_Generators is -- try and may have to iterate a number of times. This constant bounds the -- number of tries. - type Optimization is (Memory_Space, CPU_Time); + type Optimization is new SPHG.Optimization; -- Optimize either the memory space or the execution time. Note: in -- practice, the optimization mode has little effect on speed. The tables -- are somewhat smaller with Memory_Space. - Verbose : Boolean := False; + Verbose : Boolean renames SPHG.Verbose; -- Output the status of the algorithm. For instance, the tables, the random -- graph (edges, vertices) and selected char positions are output between -- two iterations. @@ -106,10 +110,10 @@ package GNAT.Perfect_Hash_Generators is -- the same words. -- -- A classical way of doing is to Insert all the words and then to invoke - -- Initialize and Compute. If Compute fails to find a perfect hash - -- function, invoke Initialize another time with other configuration - -- parameters (probably with a greater K_To_V ratio). Once successful, - -- invoke Produce and Finalize. + -- Initialize and Compute. If this fails to find a perfect hash function, + -- invoke Initialize again with other configuration parameters (probably + -- with a greater K_To_V ratio). Once successful, invoke Produce and then + -- Finalize. procedure Finalize; -- Deallocate the internal structures and the words table @@ -117,7 +121,7 @@ package GNAT.Perfect_Hash_Generators is procedure Insert (Value : String); -- Insert a new word into the table. ASCII.NUL characters are not allowed. - Too_Many_Tries : exception; + Too_Many_Tries : exception renames SPHG.Too_Many_Tries; -- Raised after Tries unsuccessful runs procedure Compute (Position : String := Default_Position); @@ -138,101 +142,4 @@ package GNAT.Perfect_Hash_Generators is -- GNAT file name for a package named Pkg_Name. If Use_Stdout is True, the -- output goes to standard output, and no files are written. - ---------------------------------------------------------------- - - -- The routines and structures defined below allow producing the hash - -- function using a different way from the procedure above. The procedure - -- Define returns the lengths of an internal table and its item type size. - -- The function Value returns the value of each item in the table. - - -- The hash function has the following form: - - -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m - - -- G is a function based on a graph table [0,n-1] -> [0,m-1]. m is the - -- number of keys. n is an internally computed value and it can be obtained - -- as the length of vector G. - - -- F1 and F2 are two functions based on two function tables T1 and T2. - -- Their definition depends on the chosen optimization mode. - - -- Only some character positions are used in the words because they are - -- significant. They are listed in a character position table (P in the - -- pseudo-code below). For instance, in {"jan", "feb", "mar", "apr", "jun", - -- "jul", "aug", "sep", "oct", "nov", "dec"}, only positions 2 and 3 are - -- significant (the first character can be ignored). In this example, P = - -- {2, 3} - - -- When Optimization is CPU_Time, the first dimension of T1 and T2 - -- corresponds to the character position in the word and the second to the - -- character set. As all the character set is not used, we define a used - -- character table which associates a distinct index to each used character - -- (unused characters are mapped to zero). In this case, the second - -- dimension of T1 and T2 is reduced to the used character set (C in the - -- pseudo-code below). Therefore, the hash function has the following: - - -- function Hash (S : String) return Natural is - -- F : constant Natural := S'First - 1; - -- L : constant Natural := S'Length; - -- F1, F2 : Natural := 0; - -- J : ; - - -- begin - -- for K in P'Range loop - -- exit when L < P (K); - -- J := C (S (P (K) + F)); - -- F1 := (F1 + Natural (T1 (K, J))) mod ; - -- F2 := (F2 + Natural (T2 (K, J))) mod ; - -- end loop; - - -- return (Natural (G (F1)) + Natural (G (F2))) mod ; - -- end Hash; - - -- When Optimization is Memory_Space, the first dimension of T1 and T2 - -- corresponds to the character position in the word and the second - -- dimension is ignored. T1 and T2 are no longer matrices but vectors. - -- Therefore, the used character table is not available. The hash function - -- has the following form: - - -- function Hash (S : String) return Natural is - -- F : constant Natural := S'First - 1; - -- L : constant Natural := S'Length; - -- F1, F2 : Natural := 0; - -- J : ; - - -- begin - -- for K in P'Range loop - -- exit when L < P (K); - -- J := Character'Pos (S (P (K) + F)); - -- F1 := (F1 + Natural (T1 (K) * J)) mod ; - -- F2 := (F2 + Natural (T2 (K) * J)) mod ; - -- end loop; - - -- return (Natural (G (F1)) + Natural (G (F2))) mod ; - -- end Hash; - - type Table_Name is - (Character_Position, - Used_Character_Set, - Function_Table_1, - Function_Table_2, - Graph_Table); - - procedure Define - (Name : Table_Name; - Item_Size : out Natural; - Length_1 : out Natural; - Length_2 : out Natural); - -- Return the definition of the table Name. This includes the length of - -- dimensions 1 and 2 and the size of an unsigned integer item. When - -- Length_2 is zero, the table has only one dimension. All the ranges - -- start from zero. - - function Value - (Name : Table_Name; - J : Natural; - K : Natural := 0) return Natural; - -- Return the value of the component (I, J) of the table Name. When the - -- table has only one dimension, J is ignored. - end GNAT.Perfect_Hash_Generators; diff --git a/gcc/ada/libgnat/g-table.ads b/gcc/ada/libgnat/g-table.ads index cfb78f1213a1..7d3ef58713fc 100644 --- a/gcc/ada/libgnat/g-table.ads +++ b/gcc/ada/libgnat/g-table.ads @@ -41,6 +41,8 @@ -- GNAT.Table -- Table (the compiler unit) +pragma Compiler_Unit_Warning; + with GNAT.Dynamic_Tables; generic diff --git a/gcc/ada/libgnat/s-imgenu.adb b/gcc/ada/libgnat/s-imagen.adb similarity index 50% rename from gcc/ada/libgnat/s-imgenu.adb rename to gcc/ada/libgnat/s-imagen.adb index 2c8725cbcf24..48c2e9fc30d7 100644 --- a/gcc/ada/libgnat/s-imgenu.adb +++ b/gcc/ada/libgnat/s-imagen.adb @@ -2,11 +2,11 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- S Y S T E M . I M G _ E N U M -- +-- S Y S T E M . I M A G E _ N -- -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2021, Free Software Foundation, Inc. -- +-- Copyright (C) 2021, Free Software Foundation, Inc. -- -- -- -- 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,54 +29,28 @@ -- -- ------------------------------------------------------------------------------ -pragma Compiler_Unit_Warning; - with Ada.Unchecked_Conversion; -package body System.Img_Enum is +package body System.Image_N is - ------------------------- - -- Image_Enumeration_8 -- - ------------------------- + ----------------------- + -- Image_Enumeration -- + ----------------------- - function Image_Enumeration_8 + procedure Image_Enumeration (Pos : Natural; + S : in out String; + P : out Natural; Names : String; Indexes : System.Address) - return String is - type Natural_8 is range 0 .. 2 ** 7 - 1; - type Index_Table is array (Natural) of Natural_8; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - Start : constant Natural := Natural (IndexesT (Pos)); - Next : constant Natural := Natural (IndexesT (Pos + 1)); - - subtype Result_Type is String (1 .. Next - Start); - -- We need this result type to force the result to have the - -- required lower bound of 1, rather than the slice bounds. - - begin - return Result_Type (Names (Start .. Next - 1)); - end Image_Enumeration_8; - - -------------------------- - -- Image_Enumeration_16 -- - -------------------------- + pragma Assert (S'First = 1); - function Image_Enumeration_16 - (Pos : Natural; - Names : String; - Indexes : System.Address) - return String - is - type Natural_16 is range 0 .. 2 ** 15 - 1; - type Index_Table is array (Natural) of Natural_16; + subtype Names_Index is + Index_Type range Index_Type (Names'First) + .. Index_Type (Names'Last) + 1; + subtype Index is Natural range Natural'First .. Names'Length; + type Index_Table is array (Index) of Names_Index; type Index_Table_Ptr is access Index_Table; function To_Index_Table_Ptr is @@ -84,45 +58,22 @@ package body System.Img_Enum is IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - Start : constant Natural := Natural (IndexesT (Pos)); - Next : constant Natural := Natural (IndexesT (Pos + 1)); - - subtype Result_Type is String (1 .. Next - Start); - -- We need this result type to force the result to have the - -- required lower bound of 1, rather than the slice bounds. - - begin - return Result_Type (Names (Start .. Next - 1)); - end Image_Enumeration_16; - - -------------------------- - -- Image_Enumeration_32 -- - -------------------------- - - function Image_Enumeration_32 - (Pos : Natural; - Names : String; - Indexes : System.Address) - return String - is - type Natural_32 is range 0 .. 2 ** 31 - 1; - type Index_Table is array (Natural) of Natural_32; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + pragma Assert (Pos in IndexesT'Range); + pragma Assert (Pos + 1 in IndexesT'Range); Start : constant Natural := Natural (IndexesT (Pos)); Next : constant Natural := Natural (IndexesT (Pos + 1)); - subtype Result_Type is String (1 .. Next - Start); - -- We need this result type to force the result to have the - -- required lower bound of 1, rather than the slice bounds. + pragma Assert (Next - 1 >= Start); + pragma Assert (Start >= Names'First); + pragma Assert (Next - 1 <= Names'Last); + pragma Assert (Next - Start <= S'Last); + -- The caller should guarantee that S is large enough to contain the + -- enumeration image. begin - return Result_Type (Names (Start .. Next - 1)); - end Image_Enumeration_32; + S (1 .. Next - Start) := Names (Start .. Next - 1); + P := Next - Start; + end Image_Enumeration; -end System.Img_Enum; +end System.Image_N; diff --git a/gcc/ada/libgnat/s-imgenu.ads b/gcc/ada/libgnat/s-imagen.ads similarity index 67% rename from gcc/ada/libgnat/s-imgenu.ads rename to gcc/ada/libgnat/s-imagen.ads index fde7bd077e10..6598be90b8ab 100644 --- a/gcc/ada/libgnat/s-imgenu.ads +++ b/gcc/ada/libgnat/s-imagen.ads @@ -2,11 +2,11 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- S Y S T E M . I M G _ E N U M -- +-- S Y S T E M . I M A G E _ N -- -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2021, Free Software Foundation, Inc. -- +-- Copyright (C) 2021, Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -34,45 +34,30 @@ -- package System (where it is too early to start building image tables). -- Special routines exist for the enumeration types in these packages. --- Note: this is an obsolete package, replaced by System.Img_Enum_New, which --- provides procedures instead of functions for these enumeration image calls. --- The reason we maintain this package is that when bootstrapping with old --- compilers, the old compiler will search for this unit, expecting to find --- these functions. The new compiler will search for procedures in the new --- version of the unit. +generic -pragma Compiler_Unit_Warning; + type Index_Type is range <>; -package System.Img_Enum is +package System.Image_N is pragma Pure; - function Image_Enumeration_8 + procedure Image_Enumeration (Pos : Natural; + S : in out String; + P : out Natural; Names : String; - Indexes : System.Address) return String; + Indexes : System.Address); -- Used to compute Enum'Image (Str) where Enum is some enumeration type - -- other than those defined in package Standard. Names is a string with a - -- lower bound of 1 containing the characters of all the enumeration - -- literals concatenated together in sequence. Indexes is the address of an - -- array of type array (0 .. N) of Natural_8, where N is the number of + -- other than those defined in package Standard. Names is a string with + -- a lower bound of 1 containing the characters of all the enumeration + -- literals concatenated together in sequence. Indexes is the address of + -- an array of type array (0 .. N) of Index_Type, where N is the number of -- enumeration literals in the type. The Indexes values are the starting -- subscript of each enumeration literal, indexed by Pos values, with an -- extra entry at the end containing Names'Length + 1. The reason that -- Indexes is passed by address is that the actual type is created on the - -- fly by the expander. The value returned is the desired 'Image value. + -- fly by the expander. The desired 'Image value is stored in S (1 .. P) + -- and P is set on return. The caller guarantees that S is long enough to + -- hold the result and that the lower bound is 1. - function Image_Enumeration_16 - (Pos : Natural; - Names : String; - Indexes : System.Address) return String; - -- Identical to Image_Enumeration_8 except that it handles types - -- using array (0 .. Num) of Natural_16 for the Indexes table. - - function Image_Enumeration_32 - (Pos : Natural; - Names : String; - Indexes : System.Address) return String; - -- Identical to Image_Enumeration_8 except that it handles types - -- using array (0 .. Num) of Natural_32 for the Indexes table. - -end System.Img_Enum; +end System.Image_N; diff --git a/gcc/ada/libgnat/s-imen16.ads b/gcc/ada/libgnat/s-imen16.ads new file mode 100644 index 000000000000..755549eff067 --- /dev/null +++ b/gcc/ada/libgnat/s-imen16.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ E N U M _ 1 6 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2021, Free Software Foundation, Inc. -- +-- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Instantiation of System.Image_N for enumeration types whose names table +-- has a length that fits in a 16-bit but not a 8-bit integer. + +with Interfaces; +with System.Image_N; + +package System.Img_Enum_16 is + pragma Pure; + + package Impl is new Image_N (Interfaces.Integer_16); + + procedure Image_Enumeration_16 + (Pos : Natural; + S : in out String; + P : out Natural; + Names : String; + Indexes : System.Address) + renames Impl.Image_Enumeration; + +end System.Img_Enum_16; diff --git a/gcc/ada/libgnat/s-imen32.ads b/gcc/ada/libgnat/s-imen32.ads new file mode 100644 index 000000000000..3cb88d8ea7e7 --- /dev/null +++ b/gcc/ada/libgnat/s-imen32.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ E N U M _ 3 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2021, Free Software Foundation, Inc. -- +-- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Instantiation of System.Image_N for enumeration types whose names table +-- has a length that fits in a 32-bit but not a 16-bit integer. + +with Interfaces; +with System.Image_N; + +package System.Img_Enum_32 is + pragma Pure; + + package Impl is new Image_N (Interfaces.Integer_32); + + procedure Image_Enumeration_32 + (Pos : Natural; + S : in out String; + P : out Natural; + Names : String; + Indexes : System.Address) + renames Impl.Image_Enumeration; + +end System.Img_Enum_32; diff --git a/gcc/ada/libgnat/s-imenne.ads b/gcc/ada/libgnat/s-imenne.ads index bdc98f1043f5..eba31c2b09d5 100644 --- a/gcc/ada/libgnat/s-imenne.ads +++ b/gcc/ada/libgnat/s-imenne.ads @@ -34,11 +34,11 @@ -- package System (where it is too early to start building image tables). -- Special routines exist for the enumeration types in these packages. --- This is the new version of the package, for use by compilers built after --- Nov 21st, 2007, which provides procedures that avoid using the secondary --- stack. The original package System.Img_Enum is maintained in the sources --- for bootstrapping with older versions of the compiler which expect to find --- functions in this package. +-- Note: this is an obsolete package replaced by instantiations of the generic +-- package System.Image_N. The reason we maintain this package is that when +-- bootstrapping with an old compiler, the old compiler will search for this +-- unit, expecting to find these functions. The new compiler will search for +-- procedures in the instances of System.Image_N instead. pragma Compiler_Unit_Warning; diff --git a/gcc/ada/libgnat/s-imenu8.ads b/gcc/ada/libgnat/s-imenu8.ads new file mode 100644 index 000000000000..8c5a64d9d4d8 --- /dev/null +++ b/gcc/ada/libgnat/s-imenu8.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ E N U M _ 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2021, Free Software Foundation, Inc. -- +-- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Instantiation of System.Image_N for enumeration types whose names table +-- has a length that fits in a 8-bit integer. + +with Interfaces; +with System.Image_N; + +package System.Img_Enum_8 is + pragma Pure; + + package Impl is new Image_N (Interfaces.Integer_8); + + procedure Image_Enumeration_8 + (Pos : Natural; + S : in out String; + P : out Natural; + Names : String; + Indexes : System.Address) + renames Impl.Image_Enumeration; + +end System.Img_Enum_8; diff --git a/gcc/ada/libgnat/s-pehage.adb b/gcc/ada/libgnat/s-pehage.adb new file mode 100644 index 000000000000..218c1cbc891e --- /dev/null +++ b/gcc/ada/libgnat/s-pehage.adb @@ -0,0 +1,2235 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P E R F E C T _ H A S H _ G E N E R A T O R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2021, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.Heap_Sort_G; +with GNAT.Table; + +with System.OS_Lib; use System.OS_Lib; + +package body System.Perfect_Hash_Generators is + + -- We are using the algorithm of J. Czech as described in Zbigniew J. + -- Czech, George Havas, and Bohdan S. Majewski ``An Optimal Algorithm for + -- Generating Minimal Perfect Hash Functions'', Information Processing + -- Letters, 43(1992) pp.257-264, Oct.1992 + + -- This minimal perfect hash function generator is based on random graphs + -- and produces a hash function of the form: + + -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m + + -- where f1 and f2 are functions that map strings into integers, and g is + -- a function that maps integers into [0, m-1]. h can be order preserving. + -- For instance, let W = {w_0, ..., w_i, ..., w_m-1}, h can be defined + -- such that h (w_i) = i. + + -- This algorithm defines two possible constructions of f1 and f2. Method + -- b) stores the hash function in less memory space at the expense of + -- greater CPU time. + + -- a) fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n + + -- size (Tk) = max (for w in W) (length (w)) * size (used char set) + + -- b) fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n + + -- size (Tk) = max (for w in W) (length (w)) but the table lookups are + -- replaced by multiplications. + + -- where Tk values are randomly generated. n is defined later on but the + -- algorithm recommends to use a value a little bit greater than 2m. Note + -- that for large values of m, the main memory space requirements comes + -- from the memory space for storing function g (>= 2m entries). + + -- Random graphs are frequently used to solve difficult problems that do + -- not have polynomial solutions. This algorithm is based on a weighted + -- undirected graph. It comprises two steps: mapping and assignment. + + -- In the mapping step, a graph G = (V, E) is constructed, where = {0, 1, + -- ..., n-1} and E = {(for w in W) (f1 (w), f2 (w))}. In order for the + -- assignment step to be successful, G has to be acyclic. To have a high + -- probability of generating an acyclic graph, n >= 2m. If it is not + -- acyclic, Tk have to be regenerated. + + -- In the assignment step, the algorithm builds function g. As G is + -- acyclic, there is a vertex v1 with only one neighbor v2. Let w_i be + -- the word such that v1 = f1 (w_i) and v2 = f2 (w_i). Let g (v1) = 0 by + -- construction and g (v2) = (i - g (v1)) mod n (or h (i) - g (v1) mod n). + -- If word w_j is such that v2 = f1 (w_j) and v3 = f2 (w_j), g (v3) = (j - + -- g (v2)) mod (or to be general, (h (j) - g (v2)) mod n). If w_i has no + -- neighbor, then another vertex is selected. The algorithm traverses G to + -- assign values to all the vertices. It cannot assign a value to an + -- already assigned vertex as G is acyclic. + + subtype Word_Id is Integer; + subtype Key_Id is Integer; + subtype Vertex_Id is Integer; + subtype Edge_Id is Integer; + subtype Table_Id is Integer; + + No_Vertex : constant Vertex_Id := -1; + No_Edge : constant Edge_Id := -1; + No_Table : constant Table_Id := -1; + + type Word_Type is new String_Access; + procedure Free_Word (W : in out Word_Type) renames Free; + function New_Word (S : String) return Word_Type; + + procedure Resize_Word (W : in out Word_Type; Len : Natural); + -- Resize string W to have a length Len + + type Key_Type is record + Edge : Edge_Id; + end record; + -- A key corresponds to an edge in the algorithm graph + + type Vertex_Type is record + First : Edge_Id; + Last : Edge_Id; + end record; + -- A vertex can be involved in several edges. First and Last are the bounds + -- of an array of edges stored in a global edge table. + + type Edge_Type is record + X : Vertex_Id; + Y : Vertex_Id; + Key : Key_Id; + end record; + -- An edge is a peer of vertices. In the algorithm, a key is associated to + -- an edge. + + package WT is new GNAT.Table (Word_Type, Word_Id, 0, 32, 32); + package IT is new GNAT.Table (Integer, Integer, 0, 32, 32); + -- The two main tables. WT is used to store the words in their initial + -- version and in their reduced version (that is words reduced to their + -- significant characters). As an instance of GNAT.Table, WT does not + -- initialize string pointers to null. This initialization has to be done + -- manually when the table is allocated. IT is used to store several + -- tables of components containing only integers. + + function Image (Int : Integer; W : Natural := 0) return String; + function Image (Str : String; W : Natural := 0) return String; + -- Return a string which includes string Str or integer Int preceded by + -- leading spaces if required by width W. + + function Trim_Trailing_Nuls (Str : String) return String; + -- Return Str with trailing NUL characters removed + + Output : File_Descriptor renames System.OS_Lib.Standout; + -- Shortcuts + + EOL : constant Character := ASCII.LF; + + Max : constant := 78; + Last : Natural := 0; + Line : String (1 .. Max); + -- Use this line to provide buffered IO + + procedure Add (C : Character); + procedure Add (S : String); + -- Add a character or a string in Line and update Last + + procedure Put + (F : File_Descriptor; + S : String; + F1 : Natural; + L1 : Natural; + C1 : Natural; + F2 : Natural; + L2 : Natural; + C2 : Natural); + -- Write string S into file F as a element of an array of one or two + -- dimensions. Fk (resp. Lk and Ck) indicates the first (resp last and + -- current) index in the k-th dimension. If F1 = L1 the array is considered + -- as a one dimension array. This dimension is described by F2 and L2. This + -- routine takes care of all the parenthesis, spaces and commas needed to + -- format correctly the array. Moreover, the array is well indented and is + -- wrapped to fit in a 80 col line. When the line is full, the routine + -- writes it into file F. When the array is completed, the routine adds + -- semi-colon and writes the line into file F. + + procedure New_Line (File : File_Descriptor); + -- Simulate Ada.Text_IO.New_Line with GNAT.OS_Lib + + procedure Put (File : File_Descriptor; Str : String); + -- Simulate Ada.Text_IO.Put with GNAT.OS_Lib + + procedure Put_Used_Char_Set (File : File_Descriptor; Title : String); + -- Output a title and a used character set + + procedure Put_Int_Vector + (File : File_Descriptor; + Title : String; + Vector : Integer; + Length : Natural); + -- Output a title and a vector + + procedure Put_Int_Matrix + (File : File_Descriptor; + Title : String; + Table : Table_Id; + Len_1 : Natural; + Len_2 : Natural); + -- Output a title and a matrix. When the matrix has only one non-empty + -- dimension (Len_2 = 0), output a vector. + + procedure Put_Edges (File : File_Descriptor; Title : String); + -- Output a title and an edge table + + procedure Put_Initial_Keys (File : File_Descriptor; Title : String); + -- Output a title and a key table + + procedure Put_Reduced_Keys (File : File_Descriptor; Title : String); + -- Output a title and a key table + + procedure Put_Vertex_Table (File : File_Descriptor; Title : String); + -- Output a title and a vertex table + + ---------------------------------- + -- Character Position Selection -- + ---------------------------------- + + -- We reduce the maximum key size by selecting representative positions + -- in these keys. We build a matrix with one word per line. We fill the + -- remaining space of a line with ASCII.NUL. The heuristic selects the + -- position that induces the minimum number of collisions. If there are + -- collisions, select another position on the reduced key set responsible + -- of the collisions. Apply the heuristic until there is no more collision. + + procedure Apply_Position_Selection; + -- Apply Position selection and build the reduced key table + + procedure Parse_Position_Selection (Argument : String); + -- Parse Argument and compute the position set. Argument is list of + -- substrings separated by commas. Each substring represents a position + -- or a range of positions (like x-y). + + procedure Select_Character_Set; + -- Define an optimized used character set like Character'Pos in order not + -- to allocate tables of 256 entries. + + procedure Select_Char_Position; + -- Find a min char position set in order to reduce the max key length. The + -- heuristic selects the position that induces the minimum number of + -- collisions. If there are collisions, select another position on the + -- reduced key set responsible of the collisions. Apply the heuristic until + -- there is no collision. + + ----------------------------- + -- Random Graph Generation -- + ----------------------------- + + procedure Random (Seed : in out Natural); + -- Simulate Ada.Discrete_Numerics.Random + + procedure Generate_Mapping_Table + (Tab : Table_Id; + L1 : Natural; + L2 : Natural; + Seed : in out Natural); + -- Random generation of the tables below. T is already allocated + + procedure Generate_Mapping_Tables + (Opt : Optimization; + Seed : in out Natural); + -- Generate the mapping tables T1 and T2. They are used to define fk (w) = + -- sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n. Keys, NK and Chars + -- are used to compute the matrix size. + + --------------------------- + -- Algorithm Computation -- + --------------------------- + + procedure Compute_Edges_And_Vertices (Opt : Optimization); + -- Compute the edge and vertex tables. These are empty when a self loop is + -- detected (f1 (w) = f2 (w)). The edge table is sorted by X value and then + -- Y value. Keys is the key table and NK the number of keys. Chars is the + -- set of characters really used in Keys. NV is the number of vertices + -- recommended by the algorithm. T1 and T2 are the mapping tables needed to + -- compute f1 (w) and f2 (w). + + function Acyclic return Boolean; + -- Return True when the graph is acyclic. Vertices is the current vertex + -- table and Edges the current edge table. + + procedure Assign_Values_To_Vertices; + -- Execute the assignment step of the algorithm. Keys is the current key + -- table. Vertices and Edges represent the random graph. G is the result of + -- the assignment step such that: + -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m + + function Sum + (Word : Word_Type; + Table : Table_Id; + Opt : Optimization) return Natural; + -- For an optimization of CPU_Time return + -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n + -- For an optimization of Memory_Space return + -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n + -- Here NV = n + + ------------------------------- + -- Internal Table Management -- + ------------------------------- + + function Allocate (N : Natural; S : Natural := 1) return Table_Id; + -- Allocate N * S ints from IT table + + ---------- + -- Keys -- + ---------- + + Keys : Table_Id := No_Table; + NK : Natural := 0; + -- NK : Number of Keys + + function Initial (K : Key_Id) return Word_Id; + pragma Inline (Initial); + + function Reduced (K : Key_Id) return Word_Id; + pragma Inline (Reduced); + + function Get_Key (N : Key_Id) return Key_Type; + procedure Set_Key (N : Key_Id; Item : Key_Type); + -- Get or Set Nth element of Keys table + + ------------------ + -- Char_Pos_Set -- + ------------------ + + Char_Pos_Set : Table_Id := No_Table; + Char_Pos_Set_Len : Natural; + -- Character Selected Position Set + + function Get_Char_Pos (P : Natural) return Natural; + procedure Set_Char_Pos (P : Natural; Item : Natural); + -- Get or Set the string position of the Pth selected character + + ------------------- + -- Used_Char_Set -- + ------------------- + + Used_Char_Set : Table_Id := No_Table; + Used_Char_Set_Len : Natural; + -- Used Character Set : Define a new character mapping. When all the + -- characters are not present in the keys, in order to reduce the size + -- of some tables, we redefine the character mapping. + + function Get_Used_Char (C : Character) return Natural; + procedure Set_Used_Char (C : Character; Item : Natural); + + ------------ + -- Tables -- + ------------ + + T1 : Table_Id := No_Table; + T2 : Table_Id := No_Table; + T1_Len : Natural; + T2_Len : Natural; + -- T1 : Values table to compute F1 + -- T2 : Values table to compute F2 + + function Get_Table (T : Integer; X, Y : Natural) return Natural; + procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural); + + ----------- + -- Graph -- + ----------- + + G : Table_Id := No_Table; + G_Len : Natural; + -- Values table to compute G + + NT : Natural; + -- Number of tries running the algorithm before raising an error + + function Get_Graph (N : Natural) return Integer; + procedure Set_Graph (N : Natural; Item : Integer); + -- Get or Set Nth element of graph + + ----------- + -- Edges -- + ----------- + + Edge_Size : constant := 3; + Edges : Table_Id := No_Table; + Edges_Len : Natural; + -- Edges : Edge table of the random graph G + + function Get_Edges (F : Natural) return Edge_Type; + procedure Set_Edges (F : Natural; Item : Edge_Type); + + -------------- + -- Vertices -- + -------------- + + Vertex_Size : constant := 2; + + Vertices : Table_Id := No_Table; + -- Vertex table of the random graph G + + NV : Natural; + -- Number of Vertices + + function Get_Vertices (F : Natural) return Vertex_Type; + procedure Set_Vertices (F : Natural; Item : Vertex_Type); + -- Comments needed ??? + + Opt : Optimization; + -- Optimization mode (memory vs CPU) + + Max_Key_Len : Natural := 0; + Min_Key_Len : Natural := 0; + -- Maximum and minimum of all the word length + + S : Natural; + -- Seed + + function Type_Size (L : Natural) return Natural; + -- Given the last L of an unsigned integer type T, return its size + + ------------- + -- Acyclic -- + ------------- + + function Acyclic return Boolean is + Marks : array (0 .. NV - 1) of Vertex_Id := (others => No_Vertex); + + function Traverse (Edge : Edge_Id; Mark : Vertex_Id) return Boolean; + -- Propagate Mark from X to Y. X is already marked. Mark Y and propagate + -- it to the edges of Y except the one representing the same key. Return + -- False when Y is marked with Mark. + + -------------- + -- Traverse -- + -------------- + + function Traverse (Edge : Edge_Id; Mark : Vertex_Id) return Boolean is + E : constant Edge_Type := Get_Edges (Edge); + K : constant Key_Id := E.Key; + Y : constant Vertex_Id := E.Y; + M : constant Vertex_Id := Marks (E.Y); + V : Vertex_Type; + + begin + if M = Mark then + return False; + + elsif M = No_Vertex then + Marks (Y) := Mark; + V := Get_Vertices (Y); + + for J in V.First .. V.Last loop + + -- Do not propagate to the edge representing the same key + + if Get_Edges (J).Key /= K + and then not Traverse (J, Mark) + then + return False; + end if; + end loop; + end if; + + return True; + end Traverse; + + Edge : Edge_Type; + + -- Start of processing for Acyclic + + begin + -- Edges valid range is + + for J in 1 .. Edges_Len - 1 loop + + Edge := Get_Edges (J); + + -- Mark X of E when it has not been already done + + if Marks (Edge.X) = No_Vertex then + Marks (Edge.X) := Edge.X; + end if; + + -- Traverse E when this has not already been done + + if Marks (Edge.Y) = No_Vertex + and then not Traverse (J, Edge.X) + then + return False; + end if; + end loop; + + return True; + end Acyclic; + + --------- + -- Add -- + --------- + + procedure Add (C : Character) is + pragma Assert (C /= ASCII.NUL); + begin + Line (Last + 1) := C; + Last := Last + 1; + end Add; + + --------- + -- Add -- + --------- + + procedure Add (S : String) is + Len : constant Natural := S'Length; + begin + for J in S'Range loop + pragma Assert (S (J) /= ASCII.NUL); + null; + end loop; + + Line (Last + 1 .. Last + Len) := S; + Last := Last + Len; + end Add; + + -------------- + -- Allocate -- + -------------- + + function Allocate (N : Natural; S : Natural := 1) return Table_Id is + L : constant Integer := IT.Last; + begin + IT.Set_Last (L + N * S); + + -- Initialize, so debugging printouts don't trip over uninitialized + -- components. + + for J in L + 1 .. IT.Last loop + IT.Table (J) := -1; + end loop; + + return L + 1; + end Allocate; + + ------------------------------ + -- Apply_Position_Selection -- + ------------------------------ + + procedure Apply_Position_Selection is + begin + for J in 0 .. NK - 1 loop + declare + IW : constant String := WT.Table (Initial (J)).all; + RW : String (1 .. IW'Length) := (others => ASCII.NUL); + N : Natural := IW'First - 1; + + begin + -- Select the characters of Word included in the position + -- selection. + + for C in 0 .. Char_Pos_Set_Len - 1 loop + exit when IW (Get_Char_Pos (C)) = ASCII.NUL; + N := N + 1; + RW (N) := IW (Get_Char_Pos (C)); + end loop; + + -- Build the new table with the reduced word. Be careful + -- to deallocate the old version to avoid memory leaks. + + Free_Word (WT.Table (Reduced (J))); + WT.Table (Reduced (J)) := New_Word (RW); + Set_Key (J, (Edge => No_Edge)); + end; + end loop; + end Apply_Position_Selection; + + ------------------------------- + -- Assign_Values_To_Vertices -- + ------------------------------- + + procedure Assign_Values_To_Vertices is + X : Vertex_Id; + + procedure Assign (X : Vertex_Id); + -- Execute assignment on X's neighbors except the vertex that we are + -- coming from which is already assigned. + + ------------ + -- Assign -- + ------------ + + procedure Assign (X : Vertex_Id) is + E : Edge_Type; + V : constant Vertex_Type := Get_Vertices (X); + + begin + for J in V.First .. V.Last loop + E := Get_Edges (J); + + if Get_Graph (E.Y) = -1 then + pragma Assert (NK /= 0); + Set_Graph (E.Y, (E.Key - Get_Graph (X)) mod NK); + Assign (E.Y); + end if; + end loop; + end Assign; + + -- Start of processing for Assign_Values_To_Vertices + + begin + -- Value -1 denotes an uninitialized value as it is supposed to + -- be in the range 0 .. NK. + + if G = No_Table then + G_Len := NV; + G := Allocate (G_Len, 1); + end if; + + for J in 0 .. G_Len - 1 loop + Set_Graph (J, -1); + end loop; + + for K in 0 .. NK - 1 loop + X := Get_Edges (Get_Key (K).Edge).X; + + if Get_Graph (X) = -1 then + Set_Graph (X, 0); + Assign (X); + end if; + end loop; + + for J in 0 .. G_Len - 1 loop + if Get_Graph (J) = -1 then + Set_Graph (J, 0); + end if; + end loop; + + if Verbose then + Put_Int_Vector (Output, "Assign Values To Vertices", G, G_Len); + end if; + end Assign_Values_To_Vertices; + + ------------- + -- Compute -- + ------------- + + procedure Compute (Position : String) is + Success : Boolean := False; + + begin + if NK = 0 then + raise Program_Error with "keywords set cannot be empty"; + end if; + + if Verbose then + Put_Initial_Keys (Output, "Initial Key Table"); + end if; + + if Position'Length /= 0 then + Parse_Position_Selection (Position); + else + Select_Char_Position; + end if; + + if Verbose then + Put_Int_Vector + (Output, "Char Position Set", Char_Pos_Set, Char_Pos_Set_Len); + end if; + + Apply_Position_Selection; + + if Verbose then + Put_Reduced_Keys (Output, "Reduced Keys Table"); + end if; + + Select_Character_Set; + + if Verbose then + Put_Used_Char_Set (Output, "Character Position Table"); + end if; + + -- Perform Czech's algorithm + + for J in 1 .. NT loop + Generate_Mapping_Tables (Opt, S); + Compute_Edges_And_Vertices (Opt); + + -- When graph is not empty (no self-loop from previous operation) and + -- not acyclic. + + if 0 < Edges_Len and then Acyclic then + Success := True; + exit; + end if; + end loop; + + if not Success then + raise Too_Many_Tries; + end if; + + Assign_Values_To_Vertices; + end Compute; + + -------------------------------- + -- Compute_Edges_And_Vertices -- + -------------------------------- + + procedure Compute_Edges_And_Vertices (Opt : Optimization) is + X : Natural; + Y : Natural; + Key : Key_Type; + Edge : Edge_Type; + Vertex : Vertex_Type; + Not_Acyclic : Boolean := False; + + procedure Move (From : Natural; To : Natural); + function Lt (L, R : Natural) return Boolean; + -- Subprograms needed for GNAT.Heap_Sort_G + + -------- + -- Lt -- + -------- + + function Lt (L, R : Natural) return Boolean is + EL : constant Edge_Type := Get_Edges (L); + ER : constant Edge_Type := Get_Edges (R); + begin + return EL.X < ER.X or else (EL.X = ER.X and then EL.Y < ER.Y); + end Lt; + + ---------- + -- Move -- + ---------- + + procedure Move (From : Natural; To : Natural) is + begin + Set_Edges (To, Get_Edges (From)); + end Move; + + package Sorting is new GNAT.Heap_Sort_G (Move, Lt); + + -- Start of processing for Compute_Edges_And_Vertices + + begin + -- We store edges from 1 to 2 * NK and leave zero alone in order to use + -- GNAT.Heap_Sort_G. + + Edges_Len := 2 * NK + 1; + + if Edges = No_Table then + Edges := Allocate (Edges_Len, Edge_Size); + end if; + + if Vertices = No_Table then + Vertices := Allocate (NV, Vertex_Size); + end if; + + for J in 0 .. NV - 1 loop + Set_Vertices (J, (No_Vertex, No_Vertex - 1)); + end loop; + + -- For each w, X = f1 (w) and Y = f2 (w) + + for J in 0 .. NK - 1 loop + Key := Get_Key (J); + Key.Edge := No_Edge; + Set_Key (J, Key); + + X := Sum (WT.Table (Reduced (J)), T1, Opt); + Y := Sum (WT.Table (Reduced (J)), T2, Opt); + + -- Discard T1 and T2 as soon as we discover a self loop + + if X = Y then + Not_Acyclic := True; + exit; + end if; + + -- We store (X, Y) and (Y, X) to ease assignment step + + Set_Edges (2 * J + 1, (X, Y, J)); + Set_Edges (2 * J + 2, (Y, X, J)); + end loop; + + -- Return an empty graph when self loop detected + + if Not_Acyclic then + Edges_Len := 0; + + else + if Verbose then + Put_Edges (Output, "Unsorted Edge Table"); + Put_Int_Matrix (Output, "Function Table 1", T1, + T1_Len, T2_Len); + Put_Int_Matrix (Output, "Function Table 2", T2, + T1_Len, T2_Len); + end if; + + -- Enforce consistency between edges and keys. Construct Vertices and + -- compute the list of neighbors of a vertex First .. Last as Edges + -- is sorted by X and then Y. To compute the neighbor list, sort the + -- edges. + + Sorting.Sort (Edges_Len - 1); + + if Verbose then + Put_Edges (Output, "Sorted Edge Table"); + Put_Int_Matrix (Output, "Function Table 1", T1, + T1_Len, T2_Len); + Put_Int_Matrix (Output, "Function Table 2", T2, + T1_Len, T2_Len); + end if; + + -- Edges valid range is 1 .. 2 * NK + + for E in 1 .. Edges_Len - 1 loop + Edge := Get_Edges (E); + Key := Get_Key (Edge.Key); + + if Key.Edge = No_Edge then + Key.Edge := E; + Set_Key (Edge.Key, Key); + end if; + + Vertex := Get_Vertices (Edge.X); + + if Vertex.First = No_Edge then + Vertex.First := E; + end if; + + Vertex.Last := E; + Set_Vertices (Edge.X, Vertex); + end loop; + + if Verbose then + Put_Reduced_Keys (Output, "Key Table"); + Put_Edges (Output, "Edge Table"); + Put_Vertex_Table (Output, "Vertex Table"); + end if; + end if; + end Compute_Edges_And_Vertices; + + ------------ + -- Define -- + ------------ + + procedure Define + (Name : Table_Name; + Item_Size : out Natural; + Length_1 : out Natural; + Length_2 : out Natural) + is + begin + case Name is + when Character_Position => + Item_Size := 31; + Length_1 := Char_Pos_Set_Len; + Length_2 := 0; + + when Used_Character_Set => + Item_Size := 8; + Length_1 := 256; + Length_2 := 0; + + when Function_Table_1 + | Function_Table_2 + => + Item_Size := Type_Size (NV); + Length_1 := T1_Len; + Length_2 := T2_Len; + + when Graph_Table => + Item_Size := Type_Size (NK); + Length_1 := NV; + Length_2 := 0; + end case; + end Define; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + begin + if Verbose then + Put (Output, "Finalize"); + New_Line (Output); + end if; + + -- Deallocate all the WT components (both initial and reduced ones) to + -- avoid memory leaks. + + for W in 0 .. WT.Last loop + + -- Note: WT.Table (NK) is a temporary variable, do not free it since + -- this would cause a double free. + + if W /= NK then + Free_Word (WT.Table (W)); + end if; + end loop; + + WT.Release; + IT.Release; + + -- Reset all variables for next usage + + Keys := No_Table; + + Char_Pos_Set := No_Table; + Char_Pos_Set_Len := 0; + + Used_Char_Set := No_Table; + Used_Char_Set_Len := 0; + + T1 := No_Table; + T2 := No_Table; + + T1_Len := 0; + T2_Len := 0; + + G := No_Table; + G_Len := 0; + + Edges := No_Table; + Edges_Len := 0; + + Vertices := No_Table; + NV := 0; + + NK := 0; + Max_Key_Len := 0; + Min_Key_Len := 0; + end Finalize; + + ---------------------------- + -- Generate_Mapping_Table -- + ---------------------------- + + procedure Generate_Mapping_Table + (Tab : Integer; + L1 : Natural; + L2 : Natural; + Seed : in out Natural) + is + begin + for J in 0 .. L1 - 1 loop + for K in 0 .. L2 - 1 loop + Random (Seed); + Set_Table (Tab, J, K, Seed mod NV); + end loop; + end loop; + end Generate_Mapping_Table; + + ----------------------------- + -- Generate_Mapping_Tables -- + ----------------------------- + + procedure Generate_Mapping_Tables + (Opt : Optimization; + Seed : in out Natural) + is + begin + -- If T1 and T2 are already allocated no need to do it twice. Reuse them + -- as their size has not changed. + + if T1 = No_Table and then T2 = No_Table then + declare + Used_Char_Last : Natural := 0; + Used_Char : Natural; + + begin + if Opt = CPU_Time then + for P in reverse Character'Range loop + Used_Char := Get_Used_Char (P); + if Used_Char /= 0 then + Used_Char_Last := Used_Char; + exit; + end if; + end loop; + end if; + + T1_Len := Char_Pos_Set_Len; + T2_Len := Used_Char_Last + 1; + T1 := Allocate (T1_Len * T2_Len); + T2 := Allocate (T1_Len * T2_Len); + end; + end if; + + Generate_Mapping_Table (T1, T1_Len, T2_Len, Seed); + Generate_Mapping_Table (T2, T1_Len, T2_Len, Seed); + + if Verbose then + Put_Used_Char_Set (Output, "Used Character Set"); + Put_Int_Matrix (Output, "Function Table 1", T1, + T1_Len, T2_Len); + Put_Int_Matrix (Output, "Function Table 2", T2, + T1_Len, T2_Len); + end if; + end Generate_Mapping_Tables; + + ------------------ + -- Get_Char_Pos -- + ------------------ + + function Get_Char_Pos (P : Natural) return Natural is + N : constant Natural := Char_Pos_Set + P; + begin + return IT.Table (N); + end Get_Char_Pos; + + --------------- + -- Get_Edges -- + --------------- + + function Get_Edges (F : Natural) return Edge_Type is + N : constant Natural := Edges + (F * Edge_Size); + E : Edge_Type; + begin + E.X := IT.Table (N); + E.Y := IT.Table (N + 1); + E.Key := IT.Table (N + 2); + return E; + end Get_Edges; + + --------------- + -- Get_Graph -- + --------------- + + function Get_Graph (N : Natural) return Integer is + begin + return IT.Table (G + N); + end Get_Graph; + + ------------- + -- Get_Key -- + ------------- + + function Get_Key (N : Key_Id) return Key_Type is + K : Key_Type; + begin + K.Edge := IT.Table (Keys + N); + return K; + end Get_Key; + + --------------- + -- Get_Table -- + --------------- + + function Get_Table (T : Integer; X, Y : Natural) return Natural is + N : constant Natural := T + (Y * T1_Len) + X; + begin + return IT.Table (N); + end Get_Table; + + ------------------- + -- Get_Used_Char -- + ------------------- + + function Get_Used_Char (C : Character) return Natural is + N : constant Natural := Used_Char_Set + Character'Pos (C); + begin + return IT.Table (N); + end Get_Used_Char; + + ------------------ + -- Get_Vertices -- + ------------------ + + function Get_Vertices (F : Natural) return Vertex_Type is + N : constant Natural := Vertices + (F * Vertex_Size); + V : Vertex_Type; + begin + V.First := IT.Table (N); + V.Last := IT.Table (N + 1); + return V; + end Get_Vertices; + + ----------- + -- Image -- + ----------- + + function Image (Int : Integer; W : Natural := 0) return String is + B : String (1 .. 32); + L : Natural := 0; + + procedure Img (V : Natural); + -- Compute image of V into B, starting at B (L), incrementing L + + --------- + -- Img -- + --------- + + procedure Img (V : Natural) is + begin + if V > 9 then + Img (V / 10); + end if; + + L := L + 1; + B (L) := Character'Val ((V mod 10) + Character'Pos ('0')); + end Img; + + -- Start of processing for Image + + begin + if Int < 0 then + L := L + 1; + B (L) := '-'; + Img (-Int); + else + Img (Int); + end if; + + return Image (B (1 .. L), W); + end Image; + + ----------- + -- Image -- + ----------- + + function Image (Str : String; W : Natural := 0) return String is + Len : constant Natural := Str'Length; + Max : Natural := Len; + + begin + if Max < W then + Max := W; + end if; + + declare + Buf : String (1 .. Max) := (1 .. Max => ' '); + + begin + for J in 0 .. Len - 1 loop + Buf (Max - Len + 1 + J) := Str (Str'First + J); + end loop; + + return Buf; + end; + end Image; + + ------------- + -- Initial -- + ------------- + + function Initial (K : Key_Id) return Word_Id is + begin + return K; + end Initial; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize + (Seed : Natural; + V : Positive; + Optim : Optimization; + Tries : Positive) + is + begin + if Verbose then + Put (Output, "Initialize"); + New_Line (Output); + end if; + + -- Deallocate the part of the table concerning the reduced words. + -- Initial words are already present in the table. We may have reduced + -- words already there because a previous computation failed. We are + -- currently retrying and the reduced words have to be deallocated. + + for W in Reduced (0) .. WT.Last loop + Free_Word (WT.Table (W)); + end loop; + + IT.Init; + + -- Initialize of computation variables + + Keys := No_Table; + + Char_Pos_Set := No_Table; + Char_Pos_Set_Len := 0; + + Used_Char_Set := No_Table; + Used_Char_Set_Len := 0; + + T1 := No_Table; + T2 := No_Table; + + T1_Len := 0; + T2_Len := 0; + + G := No_Table; + G_Len := 0; + + Edges := No_Table; + Edges_Len := 0; + + if V <= 2 * NK then + raise Program_Error with "K to V ratio cannot be lower than 2"; + end if; + + Vertices := No_Table; + NV := V; + + S := Seed; + Opt := Optim; + NT := Tries; + + Keys := Allocate (NK); + + -- Resize initial words to have all of them at the same size + -- (so the size of the largest one). + + for K in 0 .. NK - 1 loop + Resize_Word (WT.Table (Initial (K)), Max_Key_Len); + end loop; + + -- Allocated the table to store the reduced words. As WT is a + -- GNAT.Table (using C memory management), pointers have to be + -- explicitly initialized to null. + + WT.Set_Last (Reduced (NK - 1)); + + -- Note: Reduced (0) = NK + 1 + + WT.Table (NK) := null; + + for W in 0 .. NK - 1 loop + WT.Table (Reduced (W)) := null; + end loop; + end Initialize; + + ------------ + -- Insert -- + ------------ + + procedure Insert (Value : String) is + Len : constant Natural := Value'Length; + + begin + if Verbose then + Put (Output, "Inserting """ & Value & """"); + New_Line (Output); + end if; + + for J in Value'Range loop + pragma Assert (Value (J) /= ASCII.NUL); + null; + end loop; + + WT.Set_Last (NK); + WT.Table (NK) := New_Word (Value); + NK := NK + 1; + + if Max_Key_Len < Len then + Max_Key_Len := Len; + end if; + + if Min_Key_Len = 0 or else Len < Min_Key_Len then + Min_Key_Len := Len; + end if; + end Insert; + + -------------- + -- New_Line -- + -------------- + + procedure New_Line (File : File_Descriptor) is + begin + if Write (File, EOL'Address, 1) /= 1 then + raise Program_Error; + end if; + end New_Line; + + -------------- + -- New_Word -- + -------------- + + function New_Word (S : String) return Word_Type is + begin + return new String'(S); + end New_Word; + + ------------------------------ + -- Parse_Position_Selection -- + ------------------------------ + + procedure Parse_Position_Selection (Argument : String) is + N : Natural := Argument'First; + L : constant Natural := Argument'Last; + M : constant Natural := Max_Key_Len; + + T : array (1 .. M) of Boolean := (others => False); + + function Parse_Index return Natural; + -- Parse argument starting at index N to find an index + + ----------------- + -- Parse_Index -- + ----------------- + + function Parse_Index return Natural is + C : Character := Argument (N); + V : Natural := 0; + + begin + if C = '$' then + N := N + 1; + return M; + end if; + + if C not in '0' .. '9' then + raise Program_Error with "cannot read position argument"; + end if; + + while C in '0' .. '9' loop + V := V * 10 + (Character'Pos (C) - Character'Pos ('0')); + N := N + 1; + exit when L < N; + C := Argument (N); + end loop; + + return V; + end Parse_Index; + + -- Start of processing for Parse_Position_Selection + + begin + -- Empty specification means all the positions + + if L < N then + Char_Pos_Set_Len := M; + Char_Pos_Set := Allocate (Char_Pos_Set_Len); + + for C in 0 .. Char_Pos_Set_Len - 1 loop + Set_Char_Pos (C, C + 1); + end loop; + + else + loop + declare + First, Last : Natural; + + begin + First := Parse_Index; + Last := First; + + -- Detect a range + + if N <= L and then Argument (N) = '-' then + N := N + 1; + Last := Parse_Index; + end if; + + -- Include the positions in the selection + + for J in First .. Last loop + T (J) := True; + end loop; + end; + + exit when L < N; + + if Argument (N) /= ',' then + raise Program_Error with "cannot read position argument"; + end if; + + N := N + 1; + end loop; + + -- Compute position selection length + + N := 0; + for J in T'Range loop + if T (J) then + N := N + 1; + end if; + end loop; + + -- Fill position selection + + Char_Pos_Set_Len := N; + Char_Pos_Set := Allocate (Char_Pos_Set_Len); + + N := 0; + for J in T'Range loop + if T (J) then + Set_Char_Pos (N, J); + N := N + 1; + end if; + end loop; + end if; + end Parse_Position_Selection; + + --------- + -- Put -- + --------- + + procedure Put (File : File_Descriptor; Str : String) is + Len : constant Natural := Str'Length; + begin + for J in Str'Range loop + pragma Assert (Str (J) /= ASCII.NUL); + null; + end loop; + + if Write (File, Str'Address, Len) /= Len then + raise Program_Error; + end if; + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (F : File_Descriptor; + S : String; + F1 : Natural; + L1 : Natural; + C1 : Natural; + F2 : Natural; + L2 : Natural; + C2 : Natural) + is + Len : constant Natural := S'Length; + + procedure Flush; + -- Write current line, followed by LF + + ----------- + -- Flush -- + ----------- + + procedure Flush is + begin + Put (F, Line (1 .. Last)); + New_Line (F); + Last := 0; + end Flush; + + -- Start of processing for Put + + begin + if C1 = F1 and then C2 = F2 then + Last := 0; + end if; + + if Last + Len + 3 >= Max then + Flush; + end if; + + if Last = 0 then + Add (" "); + + if F1 <= L1 then + if C1 = F1 and then C2 = F2 then + Add ('('); + + if F1 = L1 then + Add ("0 .. 0 => "); + end if; + + else + Add (' '); + end if; + end if; + end if; + + if C2 = F2 then + Add ('('); + + if F2 = L2 then + Add ("0 .. 0 => "); + end if; + + else + Add (' '); + end if; + + Add (S); + + if C2 = L2 then + Add (')'); + + if F1 > L1 then + Add (';'); + Flush; + + elsif C1 /= L1 then + Add (','); + Flush; + + else + Add (')'); + Add (';'); + Flush; + end if; + + else + Add (','); + end if; + end Put; + + --------------- + -- Put_Edges -- + --------------- + + procedure Put_Edges (File : File_Descriptor; Title : String) is + E : Edge_Type; + F1 : constant Natural := 1; + L1 : constant Natural := Edges_Len - 1; + M : constant Natural := Max / 5; + + begin + Put (File, Title); + New_Line (File); + + -- Edges valid range is 1 .. Edge_Len - 1 + + for J in F1 .. L1 loop + E := Get_Edges (J); + Put (File, Image (J, M), F1, L1, J, 1, 4, 1); + Put (File, Image (E.X, M), F1, L1, J, 1, 4, 2); + Put (File, Image (E.Y, M), F1, L1, J, 1, 4, 3); + Put (File, Image (E.Key, M), F1, L1, J, 1, 4, 4); + end loop; + end Put_Edges; + + ---------------------- + -- Put_Initial_Keys -- + ---------------------- + + procedure Put_Initial_Keys (File : File_Descriptor; Title : String) is + F1 : constant Natural := 0; + L1 : constant Natural := NK - 1; + M : constant Natural := Max / 5; + K : Key_Type; + + begin + Put (File, Title); + New_Line (File); + + for J in F1 .. L1 loop + K := Get_Key (J); + Put (File, Image (J, M), F1, L1, J, 1, 3, 1); + Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2); + Put (File, Trim_Trailing_Nuls (WT.Table (Initial (J)).all), + F1, L1, J, 1, 3, 3); + end loop; + end Put_Initial_Keys; + + -------------------- + -- Put_Int_Matrix -- + -------------------- + + procedure Put_Int_Matrix + (File : File_Descriptor; + Title : String; + Table : Integer; + Len_1 : Natural; + Len_2 : Natural) + is + F1 : constant Integer := 0; + L1 : constant Integer := Len_1 - 1; + F2 : constant Integer := 0; + L2 : constant Integer := Len_2 - 1; + Ix : Natural; + + begin + Put (File, Title); + New_Line (File); + + if Len_2 = 0 then + for J in F1 .. L1 loop + Ix := IT.Table (Table + J); + Put (File, Image (Ix), 1, 0, 1, F1, L1, J); + end loop; + + else + for J in F1 .. L1 loop + for K in F2 .. L2 loop + Ix := IT.Table (Table + J + K * Len_1); + Put (File, Image (Ix), F1, L1, J, F2, L2, K); + end loop; + end loop; + end if; + end Put_Int_Matrix; + + -------------------- + -- Put_Int_Vector -- + -------------------- + + procedure Put_Int_Vector + (File : File_Descriptor; + Title : String; + Vector : Integer; + Length : Natural) + is + F2 : constant Natural := 0; + L2 : constant Natural := Length - 1; + + begin + Put (File, Title); + New_Line (File); + + for J in F2 .. L2 loop + Put (File, Image (IT.Table (Vector + J)), 1, 0, 1, F2, L2, J); + end loop; + end Put_Int_Vector; + + ---------------------- + -- Put_Reduced_Keys -- + ---------------------- + + procedure Put_Reduced_Keys (File : File_Descriptor; Title : String) is + F1 : constant Natural := 0; + L1 : constant Natural := NK - 1; + M : constant Natural := Max / 5; + K : Key_Type; + + begin + Put (File, Title); + New_Line (File); + + for J in F1 .. L1 loop + K := Get_Key (J); + Put (File, Image (J, M), F1, L1, J, 1, 3, 1); + Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2); + Put (File, Trim_Trailing_Nuls (WT.Table (Reduced (J)).all), + F1, L1, J, 1, 3, 3); + end loop; + end Put_Reduced_Keys; + + ----------------------- + -- Put_Used_Char_Set -- + ----------------------- + + procedure Put_Used_Char_Set (File : File_Descriptor; Title : String) is + F : constant Natural := Character'Pos (Character'First); + L : constant Natural := Character'Pos (Character'Last); + + begin + Put (File, Title); + New_Line (File); + + for J in Character'Range loop + Put + (File, Image (Get_Used_Char (J)), 1, 0, 1, F, L, Character'Pos (J)); + end loop; + end Put_Used_Char_Set; + + ---------------------- + -- Put_Vertex_Table -- + ---------------------- + + procedure Put_Vertex_Table (File : File_Descriptor; Title : String) is + F1 : constant Natural := 0; + L1 : constant Natural := NV - 1; + M : constant Natural := Max / 4; + V : Vertex_Type; + + begin + Put (File, Title); + New_Line (File); + + for J in F1 .. L1 loop + V := Get_Vertices (J); + Put (File, Image (J, M), F1, L1, J, 1, 3, 1); + Put (File, Image (V.First, M), F1, L1, J, 1, 3, 2); + Put (File, Image (V.Last, M), F1, L1, J, 1, 3, 3); + end loop; + end Put_Vertex_Table; + + ------------ + -- Random -- + ------------ + + procedure Random (Seed : in out Natural) is + + -- Park & Miller Standard Minimal using Schrage's algorithm to avoid + -- overflow: Xn+1 = 16807 * Xn mod (2 ** 31 - 1) + + R : Natural; + Q : Natural; + X : Integer; + + begin + R := Seed mod 127773; + Q := Seed / 127773; + X := 16807 * R - 2836 * Q; + + Seed := (if X < 0 then X + 2147483647 else X); + end Random; + + ------------- + -- Reduced -- + ------------- + + function Reduced (K : Key_Id) return Word_Id is + begin + return K + NK + 1; + end Reduced; + + ----------------- + -- Resize_Word -- + ----------------- + + procedure Resize_Word (W : in out Word_Type; Len : Natural) is + S1 : constant String := W.all; + S2 : String (1 .. Len) := (others => ASCII.NUL); + L : constant Natural := S1'Length; + begin + if L /= Len then + Free_Word (W); + S2 (1 .. L) := S1; + W := New_Word (S2); + end if; + end Resize_Word; + + -------------------------- + -- Select_Char_Position -- + -------------------------- + + procedure Select_Char_Position is + + type Vertex_Table_Type is array (Natural range <>) of Vertex_Type; + + procedure Build_Identical_Keys_Sets + (Table : in out Vertex_Table_Type; + Last : in out Natural; + Pos : Natural); + -- Build a list of keys subsets that are identical with the current + -- position selection plus Pos. Once this routine is called, reduced + -- words are sorted by subsets and each item (First, Last) in Sets + -- defines the range of identical keys. + -- Need comment saying exactly what Last is ??? + + function Count_Different_Keys + (Table : Vertex_Table_Type; + Last : Natural; + Pos : Natural) return Natural; + -- For each subset in Sets, count the number of different keys if we add + -- Pos to the current position selection. + + Sel_Position : IT.Table_Type (1 .. Max_Key_Len); + Last_Sel_Pos : Natural := 0; + Max_Sel_Pos : Natural := 0; + + ------------------------------- + -- Build_Identical_Keys_Sets -- + ------------------------------- + + procedure Build_Identical_Keys_Sets + (Table : in out Vertex_Table_Type; + Last : in out Natural; + Pos : Natural) + is + S : constant Vertex_Table_Type := Table (Table'First .. Last); + C : constant Natural := Pos; + -- Shortcuts (why are these not renames ???) + + F : Integer; + L : Integer; + -- First and last words of a subset + + Offset : Natural; + -- GNAT.Heap_Sort assumes that the first array index is 1. Offset + -- defines the translation to operate. + + function Lt (L, R : Natural) return Boolean; + procedure Move (From : Natural; To : Natural); + -- Subprograms needed by GNAT.Heap_Sort_G + + -------- + -- Lt -- + -------- + + function Lt (L, R : Natural) return Boolean is + C : constant Natural := Pos; + Left : Natural; + Right : Natural; + + begin + if L = 0 then + Left := NK; + Right := Offset + R; + elsif R = 0 then + Left := Offset + L; + Right := NK; + else + Left := Offset + L; + Right := Offset + R; + end if; + + return WT.Table (Left)(C) < WT.Table (Right)(C); + end Lt; + + ---------- + -- Move -- + ---------- + + procedure Move (From : Natural; To : Natural) is + Target, Source : Natural; + + begin + if From = 0 then + Source := NK; + Target := Offset + To; + elsif To = 0 then + Source := Offset + From; + Target := NK; + else + Source := Offset + From; + Target := Offset + To; + end if; + + WT.Table (Target) := WT.Table (Source); + WT.Table (Source) := null; + end Move; + + package Sorting is new GNAT.Heap_Sort_G (Move, Lt); + + -- Start of processing for Build_Identical_Key_Sets + + begin + Last := 0; + + -- For each subset in S, extract the new subsets we have by adding C + -- in the position selection. + + for J in S'Range loop + pragma Annotate (CodePeer, Modified, S (J)); + + if S (J).First = S (J).Last then + F := S (J).First; + L := S (J).Last; + Last := Last + 1; + Table (Last) := (F, L); + + else + Offset := Reduced (S (J).First) - 1; + Sorting.Sort (S (J).Last - S (J).First + 1); + + F := S (J).First; + L := F; + for N in S (J).First .. S (J).Last loop + + -- For the last item, close the last subset + + if N = S (J).Last then + Last := Last + 1; + Table (Last) := (F, N); + + -- Two contiguous words are identical when they have the + -- same Cth character. + + elsif WT.Table (Reduced (N))(C) = + WT.Table (Reduced (N + 1))(C) + then + L := N + 1; + + -- Find a new subset of identical keys. Store the current + -- one and create a new subset. + + else + Last := Last + 1; + Table (Last) := (F, L); + F := N + 1; + L := F; + end if; + end loop; + end if; + end loop; + end Build_Identical_Keys_Sets; + + -------------------------- + -- Count_Different_Keys -- + -------------------------- + + function Count_Different_Keys + (Table : Vertex_Table_Type; + Last : Natural; + Pos : Natural) return Natural + is + N : array (Character) of Natural; + C : Character; + T : Natural := 0; + + begin + -- For each subset, count the number of words that are still + -- different when we include Pos in the position selection. Only + -- focus on this position as the other positions already produce + -- identical keys. + + for S in 1 .. Last loop + + -- Count the occurrences of the different characters + + N := (others => 0); + for K in Table (S).First .. Table (S).Last loop + C := WT.Table (Reduced (K))(Pos); + N (C) := N (C) + 1; + end loop; + + -- Update the number of different keys. Each character used + -- denotes a different key. + + for J in N'Range loop + if N (J) > 0 then + T := T + 1; + end if; + end loop; + end loop; + + return T; + end Count_Different_Keys; + + -- Start of processing for Select_Char_Position + + begin + -- Initialize the reduced words set + + for K in 0 .. NK - 1 loop + WT.Table (Reduced (K)) := New_Word (WT.Table (Initial (K)).all); + end loop; + + declare + Differences : Natural; + Max_Differences : Natural := 0; + Old_Differences : Natural; + Max_Diff_Sel_Pos : Natural := 0; -- init to kill warning + Max_Diff_Sel_Pos_Idx : Natural := 0; -- init to kill warning + Same_Keys_Sets_Table : Vertex_Table_Type (1 .. NK); + Same_Keys_Sets_Last : Natural := 1; + + begin + for C in Sel_Position'Range loop + Sel_Position (C) := C; + end loop; + + Same_Keys_Sets_Table (1) := (0, NK - 1); + + loop + -- Preserve maximum number of different keys and check later on + -- that this value is strictly incrementing. Otherwise, it means + -- that two keys are strictly identical. + + Old_Differences := Max_Differences; + + -- The first position should not exceed the minimum key length. + -- Otherwise, we may end up with an empty word once reduced. + + Max_Sel_Pos := + (if Last_Sel_Pos = 0 then Min_Key_Len else Max_Key_Len); + + -- Find which position increases more the number of differences + + for J in Last_Sel_Pos + 1 .. Max_Sel_Pos loop + Differences := Count_Different_Keys + (Same_Keys_Sets_Table, + Same_Keys_Sets_Last, + Sel_Position (J)); + + if Verbose then + Put (Output, + "Selecting position" & Sel_Position (J)'Img & + " results in" & Differences'Img & + " differences"); + New_Line (Output); + end if; + + if Differences > Max_Differences then + Max_Differences := Differences; + Max_Diff_Sel_Pos := Sel_Position (J); + Max_Diff_Sel_Pos_Idx := J; + end if; + end loop; + + if Old_Differences = Max_Differences then + raise Program_Error with "some keys are identical"; + end if; + + -- Insert selected position and sort Sel_Position table + + Last_Sel_Pos := Last_Sel_Pos + 1; + Sel_Position (Last_Sel_Pos + 1 .. Max_Diff_Sel_Pos_Idx) := + Sel_Position (Last_Sel_Pos .. Max_Diff_Sel_Pos_Idx - 1); + Sel_Position (Last_Sel_Pos) := Max_Diff_Sel_Pos; + + for P in 1 .. Last_Sel_Pos - 1 loop + if Max_Diff_Sel_Pos < Sel_Position (P) then + pragma Annotate + (CodePeer, False_Positive, + "test always false", "false positive?"); + + Sel_Position (P + 1 .. Last_Sel_Pos) := + Sel_Position (P .. Last_Sel_Pos - 1); + Sel_Position (P) := Max_Diff_Sel_Pos; + exit; + end if; + end loop; + + exit when Max_Differences = NK; + + Build_Identical_Keys_Sets + (Same_Keys_Sets_Table, + Same_Keys_Sets_Last, + Max_Diff_Sel_Pos); + + if Verbose then + Put (Output, + "Selecting position" & Max_Diff_Sel_Pos'Img & + " results in" & Max_Differences'Img & + " differences"); + New_Line (Output); + Put (Output, "--"); + New_Line (Output); + for J in 1 .. Same_Keys_Sets_Last loop + for K in + Same_Keys_Sets_Table (J).First .. + Same_Keys_Sets_Table (J).Last + loop + Put (Output, + Trim_Trailing_Nuls (WT.Table (Reduced (K)).all)); + New_Line (Output); + end loop; + Put (Output, "--"); + New_Line (Output); + end loop; + end if; + end loop; + end; + + Char_Pos_Set_Len := Last_Sel_Pos; + Char_Pos_Set := Allocate (Char_Pos_Set_Len); + + for C in 1 .. Last_Sel_Pos loop + Set_Char_Pos (C - 1, Sel_Position (C)); + end loop; + end Select_Char_Position; + + -------------------------- + -- Select_Character_Set -- + -------------------------- + + procedure Select_Character_Set is + Last : Natural := 0; + Used : array (Character) of Boolean := (others => False); + Char : Character; + + begin + for J in 0 .. NK - 1 loop + for K in 0 .. Char_Pos_Set_Len - 1 loop + Char := WT.Table (Initial (J))(Get_Char_Pos (K)); + exit when Char = ASCII.NUL; + Used (Char) := True; + end loop; + end loop; + + Used_Char_Set_Len := 256; + Used_Char_Set := Allocate (Used_Char_Set_Len); + + for J in Used'Range loop + if Used (J) then + Set_Used_Char (J, Last); + Last := Last + 1; + else + Set_Used_Char (J, 0); + end if; + end loop; + end Select_Character_Set; + + ------------------ + -- Set_Char_Pos -- + ------------------ + + procedure Set_Char_Pos (P : Natural; Item : Natural) is + N : constant Natural := Char_Pos_Set + P; + begin + IT.Table (N) := Item; + end Set_Char_Pos; + + --------------- + -- Set_Edges -- + --------------- + + procedure Set_Edges (F : Natural; Item : Edge_Type) is + N : constant Natural := Edges + (F * Edge_Size); + begin + IT.Table (N) := Item.X; + IT.Table (N + 1) := Item.Y; + IT.Table (N + 2) := Item.Key; + end Set_Edges; + + --------------- + -- Set_Graph -- + --------------- + + procedure Set_Graph (N : Natural; Item : Integer) is + begin + IT.Table (G + N) := Item; + end Set_Graph; + + ------------- + -- Set_Key -- + ------------- + + procedure Set_Key (N : Key_Id; Item : Key_Type) is + begin + IT.Table (Keys + N) := Item.Edge; + end Set_Key; + + --------------- + -- Set_Table -- + --------------- + + procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural) is + N : constant Natural := T + ((Y * T1_Len) + X); + begin + IT.Table (N) := Item; + end Set_Table; + + ------------------- + -- Set_Used_Char -- + ------------------- + + procedure Set_Used_Char (C : Character; Item : Natural) is + N : constant Natural := Used_Char_Set + Character'Pos (C); + begin + IT.Table (N) := Item; + end Set_Used_Char; + + ------------------ + -- Set_Vertices -- + ------------------ + + procedure Set_Vertices (F : Natural; Item : Vertex_Type) is + N : constant Natural := Vertices + (F * Vertex_Size); + begin + IT.Table (N) := Item.First; + IT.Table (N + 1) := Item.Last; + end Set_Vertices; + + --------- + -- Sum -- + --------- + + function Sum + (Word : Word_Type; + Table : Table_Id; + Opt : Optimization) return Natural + is + S : Natural := 0; + R : Natural; + + begin + case Opt is + when CPU_Time => + for J in 0 .. T1_Len - 1 loop + exit when Word (J + 1) = ASCII.NUL; + R := Get_Table (Table, J, Get_Used_Char (Word (J + 1))); + pragma Assert (NV /= 0); + S := (S + R) mod NV; + end loop; + + when Memory_Space => + for J in 0 .. T1_Len - 1 loop + exit when Word (J + 1) = ASCII.NUL; + R := Get_Table (Table, J, 0); + pragma Assert (NV /= 0); + S := (S + R * Character'Pos (Word (J + 1))) mod NV; + end loop; + end case; + + return S; + end Sum; + + ------------------------ + -- Trim_Trailing_Nuls -- + ------------------------ + + function Trim_Trailing_Nuls (Str : String) return String is + begin + for J in reverse Str'Range loop + if Str (J) /= ASCII.NUL then + return Str (Str'First .. J); + end if; + end loop; + + return Str; + end Trim_Trailing_Nuls; + + --------------- + -- Type_Size -- + --------------- + + function Type_Size (L : Natural) return Natural is + begin + if L <= 2 ** 8 then + return 8; + elsif L <= 2 ** 16 then + return 16; + else + return 32; + end if; + end Type_Size; + + ----------- + -- Value -- + ----------- + + function Value + (Name : Table_Name; + J : Natural; + K : Natural := 0) return Natural + is + begin + case Name is + when Character_Position => + return Get_Char_Pos (J); + + when Used_Character_Set => + return Get_Used_Char (Character'Val (J)); + + when Function_Table_1 => + return Get_Table (T1, J, K); + + when Function_Table_2 => + return Get_Table (T2, J, K); + + when Graph_Table => + return Get_Graph (J); + end case; + end Value; + +end System.Perfect_Hash_Generators; diff --git a/gcc/ada/libgnat/s-pehage.ads b/gcc/ada/libgnat/s-pehage.ads new file mode 100644 index 000000000000..f8b8129fb210 --- /dev/null +++ b/gcc/ada/libgnat/s-pehage.ads @@ -0,0 +1,212 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P E R F E C T _ H A S H _ G E N E R A T O R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2021, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a generator of static minimal perfect hash functions. +-- To understand what a perfect hash function is, we define several notions. +-- These definitions are inspired from the following paper: + +-- Zbigniew J. Czech, George Havas, and Bohdan S. Majewski ``An Optimal +-- Algorithm for Generating Minimal Perfect Hash Functions'', Information +-- Processing Letters, 43(1992) pp.257-264, Oct.1992 + +-- Let W be a set of m words. A hash function h is a function that maps the +-- set of words W into some given interval I of integers [0, k-1], where k is +-- an integer, usually k >= m. h (w) where w is a word in W computes an +-- address or an integer from I for the storage or the retrieval of that +-- item. The storage area used to store items is known as a hash table. Words +-- for which the same address is computed are called synonyms. Due to the +-- existence of synonyms a situation called collision may arise in which two +-- items w1 and w2 have the same address. Several schemes for resolving +-- collisions are known. A perfect hash function is an injection from the word +-- set W to the integer interval I with k >= m. If k = m, then h is a minimal +-- perfect hash function. A hash function is order preserving if it puts +-- entries into the hash table in a prespecified order. + +-- A minimal perfect hash function is defined by two properties: + +-- Since no collisions occur each item can be retrieved from the table in +-- *one* probe. This represents the "perfect" property. + +-- The hash table size corresponds to the exact size of W and *no larger*. +-- This represents the "minimal" property. + +-- The functions generated by this package require the words to be known in +-- advance (they are "static" hash functions). The hash functions are also +-- order preserving. If w2 is inserted after w1 in the generator, then h (w1) +-- < h (w2). These hashing functions are convenient for use with realtime +-- applications. + +pragma Compiler_Unit_Warning; + +package System.Perfect_Hash_Generators is + + type Optimization is (Memory_Space, CPU_Time); + -- Optimize either the memory space or the execution time. Note: in + -- practice, the optimization mode has little effect on speed. The tables + -- are somewhat smaller with Memory_Space. + + Verbose : Boolean := False; + -- Output the status of the algorithm. For instance, the tables, the random + -- graph (edges, vertices) and selected char positions are output between + -- two iterations. + + procedure Initialize + (Seed : Natural; + V : Positive; + Optim : Optimization; + Tries : Positive); + -- Initialize the generator and its internal structures. Set the number of + -- vertices in the random graphs. This value has to be greater than twice + -- the number of keys in order for the algorithm to succeed. The word set + -- is not modified (in particular when it is already set). For instance, it + -- is possible to run several times the generator with different settings + -- on the same words. + -- + -- A classical way of doing is to Insert all the words and then to invoke + -- Initialize and Compute. If this fails to find a perfect hash function, + -- invoke Initialize again with other configuration parameters (probably + -- with a greater number of vertices). Once successful, invoke Define and + -- Value, and then Finalize. + + procedure Finalize; + -- Deallocate the internal structures and the words table + + procedure Insert (Value : String); + -- Insert a new word into the table. ASCII.NUL characters are not allowed. + + Too_Many_Tries : exception; + -- Raised after Tries unsuccessful runs + + procedure Compute (Position : String); + -- Compute the hash function. Position allows the definition of selection + -- of character positions used in the word hash function. Positions can be + -- separated by commas and ranges like x-y may be used. Character '$' + -- represents the final character of a word. With an empty position, the + -- generator automatically produces positions to reduce the memory usage. + -- Raise Too_Many_Tries if the algorithm does not succeed within Tries + -- attempts (see Initialize). + + -- The procedure Define returns the lengths of an internal table and its + -- item type size. The function Value returns the value of each item in + -- the table. Together they can be used to retrieve the parameters of the + -- hash function which has been computed by a call to Compute. + + -- The hash function has the following form: + + -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m + + -- G is a function based on a graph table [0,n-1] -> [0,m-1]. m is the + -- number of keys. n is an internally computed value and it can be obtained + -- as the length of vector G. + + -- F1 and F2 are two functions based on two function tables T1 and T2. + -- Their definition depends on the chosen optimization mode. + + -- Only some character positions are used in the words because they are + -- significant. They are listed in a character position table (P in the + -- pseudo-code below). For instance, in {"jan", "feb", "mar", "apr", "jun", + -- "jul", "aug", "sep", "oct", "nov", "dec"}, only positions 2 and 3 are + -- significant (the first character can be ignored). In this example, P = + -- {2, 3} + + -- When Optimization is CPU_Time, the first dimension of T1 and T2 + -- corresponds to the character position in the word and the second to the + -- character set. As all the character set is not used, we define a used + -- character table which associates a distinct index to each used character + -- (unused characters are mapped to zero). In this case, the second + -- dimension of T1 and T2 is reduced to the used character set (C in the + -- pseudo-code below). Therefore, the hash function has the following: + + -- function Hash (S : String) return Natural is + -- F : constant Natural := S'First - 1; + -- L : constant Natural := S'Length; + -- F1, F2 : Natural := 0; + -- J : ; + + -- begin + -- for K in P'Range loop + -- exit when L < P (K); + -- J := C (S (P (K) + F)); + -- F1 := (F1 + Natural (T1 (K, J))) mod ; + -- F2 := (F2 + Natural (T2 (K, J))) mod ; + -- end loop; + + -- return (Natural (G (F1)) + Natural (G (F2))) mod ; + -- end Hash; + + -- When Optimization is Memory_Space, the first dimension of T1 and T2 + -- corresponds to the character position in the word and the second + -- dimension is ignored. T1 and T2 are no longer matrices but vectors. + -- Therefore, the used character table is not available. The hash function + -- has the following form: + + -- function Hash (S : String) return Natural is + -- F : constant Natural := S'First - 1; + -- L : constant Natural := S'Length; + -- F1, F2 : Natural := 0; + -- J : ; + + -- begin + -- for K in P'Range loop + -- exit when L < P (K); + -- J := Character'Pos (S (P (K) + F)); + -- F1 := (F1 + Natural (T1 (K) * J)) mod ; + -- F2 := (F2 + Natural (T2 (K) * J)) mod ; + -- end loop; + + -- return (Natural (G (F1)) + Natural (G (F2))) mod ; + -- end Hash; + + type Table_Name is + (Character_Position, + Used_Character_Set, + Function_Table_1, + Function_Table_2, + Graph_Table); + + procedure Define + (Name : Table_Name; + Item_Size : out Natural; + Length_1 : out Natural; + Length_2 : out Natural); + -- Return the definition of the table Name. This includes the length of + -- dimensions 1 and 2 and the size of an unsigned integer item. When + -- Length_2 is zero, the table has only one dimension. All the ranges + -- start from zero. + + function Value + (Name : Table_Name; + J : Natural; + K : Natural := 0) return Natural; + -- Return the value of the component (J, K) of the table Name. When the + -- table has only one dimension, K is ignored. + +end System.Perfect_Hash_Generators; diff --git a/gcc/ada/libgnat/s-vaen16.ads b/gcc/ada/libgnat/s-vaen16.ads new file mode 100644 index 000000000000..f1197786dcee --- /dev/null +++ b/gcc/ada/libgnat/s-vaen16.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ E N U M _ 1 6 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2021, Free Software Foundation, Inc. -- +-- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Instantiation of System.Value_N for enumeration types whose names table +-- has a length that fits in a 16-bit but not a 8-bit integer. + +with Interfaces; +with System.Value_N; + +package System.Val_Enum_16 is + pragma Preelaborate; + + package Impl is new Value_N (Interfaces.Integer_16); + + function Value_Enumeration_16 + (Names : String; + Indexes : System.Address; + Hash : Impl.Hash_Function_Ptr; + Num : Natural; + Str : String) + return Natural + renames Impl.Value_Enumeration; + +end System.Val_Enum_16; diff --git a/gcc/ada/libgnat/s-vaen32.ads b/gcc/ada/libgnat/s-vaen32.ads new file mode 100644 index 000000000000..ba24af316c63 --- /dev/null +++ b/gcc/ada/libgnat/s-vaen32.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ E N U M _ 3 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2021, Free Software Foundation, Inc. -- +-- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Instantiation of System.Value_N for enumeration types whose names table +-- has a length that fits in a 32-bit but not a 16-bit integer. + +with Interfaces; +with System.Value_N; + +package System.Val_Enum_32 is + pragma Preelaborate; + + package Impl is new Value_N (Interfaces.Integer_32); + + function Value_Enumeration_32 + (Names : String; + Indexes : System.Address; + Hash : Impl.Hash_Function_Ptr; + Num : Natural; + Str : String) + return Natural + renames Impl.Value_Enumeration; + +end System.Val_Enum_32; diff --git a/gcc/ada/libgnat/s-vaenu8.ads b/gcc/ada/libgnat/s-vaenu8.ads new file mode 100644 index 000000000000..4de9b0e2e407 --- /dev/null +++ b/gcc/ada/libgnat/s-vaenu8.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ E N U M _ 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2021, Free Software Foundation, Inc. -- +-- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Instantiation of System.Value_N for enumeration types whose names table +-- has a length that fits in a 8-bit integer. + +with Interfaces; +with System.Value_N; + +package System.Val_Enum_8 is + pragma Preelaborate; + + package Impl is new Value_N (Interfaces.Integer_8); + + function Value_Enumeration_8 + (Names : String; + Indexes : System.Address; + Hash : Impl.Hash_Function_Ptr; + Num : Natural; + Str : String) + return Natural + renames Impl.Value_Enumeration; + +end System.Val_Enum_8; diff --git a/gcc/ada/libgnat/s-valenu.adb b/gcc/ada/libgnat/s-valuen.adb similarity index 52% rename from gcc/ada/libgnat/s-valenu.adb rename to gcc/ada/libgnat/s-valuen.adb index 982e09723acd..08d1a7388f46 100644 --- a/gcc/ada/libgnat/s-valenu.adb +++ b/gcc/ada/libgnat/s-valuen.adb @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- S Y S T E M . V A L _ E N U M -- +-- S Y S T E M . V A L U E _ N -- -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- +-- Copyright (C) 2021, Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -33,25 +33,30 @@ with Ada.Unchecked_Conversion; with System.Val_Util; use System.Val_Util; -package body System.Val_Enum is +package body System.Value_N is - ------------------------- - -- Value_Enumeration_8 -- - ------------------------- + ----------------------- + -- Value_Enumeration -- + ----------------------- - function Value_Enumeration_8 + function Value_Enumeration (Names : String; Indexes : System.Address; + Hash : Hash_Function_Ptr; Num : Natural; Str : String) return Natural is F : Natural; L : Natural; + H : Natural; S : String (Str'Range) := Str; - type Natural_8 is range 0 .. 2 ** 7 - 1; - type Index_Table is array (Natural) of Natural_8; + subtype Names_Index is + Index_Type range Index_Type (Names'First) + .. Index_Type (Names'Last) + 1; + subtype Index is Natural range Natural'First .. Names'Length; + type Index_Table is array (Index) of Names_Index; type Index_Table_Ptr is access Index_Table; function To_Index_Table_Ptr is @@ -59,97 +64,37 @@ package body System.Val_Enum is IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + pragma Assert (Num + 1 in IndexesT'Range); + begin Normalize_String (S, F, L); - for J in 0 .. Num loop - if Names - (Natural (IndexesT (J)) .. - Natural (IndexesT (J + 1)) - 1) = S (F .. L) - then - return J; - end if; - end loop; - - Bad_Value (Str); - end Value_Enumeration_8; - - -------------------------- - -- Value_Enumeration_16 -- - -------------------------- - - function Value_Enumeration_16 - (Names : String; - Indexes : System.Address; - Num : Natural; - Str : String) - return Natural - is - F : Natural; - L : Natural; - S : String (Str'Range) := Str; - - type Natural_16 is range 0 .. 2 ** 15 - 1; - type Index_Table is array (Natural) of Natural_16; - type Index_Table_Ptr is access Index_Table; + -- If we have a valid hash value, do a single lookup - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - begin - Normalize_String (S, F, L); + H := (if Hash /= null then Hash.all (S (F .. L)) else Natural'Last); - for J in 0 .. Num loop + if H /= Natural'Last then if Names - (Natural (IndexesT (J)) .. - Natural (IndexesT (J + 1)) - 1) = S (F .. L) + (Natural (IndexesT (H)) .. + Natural (IndexesT (H + 1)) - 1) = S (F .. L) then - return J; + return H; end if; - end loop; - Bad_Value (Str); - end Value_Enumeration_16; - - -------------------------- - -- Value_Enumeration_32 -- - -------------------------- + -- Otherwise do a linear search - function Value_Enumeration_32 - (Names : String; - Indexes : System.Address; - Num : Natural; - Str : String) - return Natural - is - F : Natural; - L : Natural; - S : String (Str'Range) := Str; - - type Natural_32 is range 0 .. 2 ** 31 - 1; - type Index_Table is array (Natural) of Natural_32; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - begin - Normalize_String (S, F, L); - - for J in 0 .. Num loop - if Names - (Natural (IndexesT (J)) .. - Natural (IndexesT (J + 1)) - 1) = S (F .. L) - then - return J; - end if; - end loop; + else + for J in 0 .. Num loop + if Names + (Natural (IndexesT (J)) .. + Natural (IndexesT (J + 1)) - 1) = S (F .. L) + then + return J; + end if; + end loop; + end if; Bad_Value (Str); - end Value_Enumeration_32; + end Value_Enumeration; -end System.Val_Enum; +end System.Value_N; diff --git a/gcc/ada/libgnat/s-valenu.ads b/gcc/ada/libgnat/s-valuen.ads similarity index 80% rename from gcc/ada/libgnat/s-valenu.ads rename to gcc/ada/libgnat/s-valuen.ads index 4e3daf028d0d..dafa45164c1a 100644 --- a/gcc/ada/libgnat/s-valenu.ads +++ b/gcc/ada/libgnat/s-valuen.ads @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- S Y S T E M . V A L _ E N U M -- +-- S Y S T E M . V A L U E _ N -- -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- +-- Copyright (C) 2021, Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -33,12 +33,19 @@ -- other than those in packages Standard and System. See unit Exp_Imgv for -- details of the format of constructed image tables. -package System.Val_Enum is +generic + + type Index_Type is range <>; + +package System.Value_N is pragma Preelaborate; - function Value_Enumeration_8 + type Hash_Function_Ptr is access function (S : String) return Natural; + + function Value_Enumeration (Names : String; Indexes : System.Address; + Hash : Hash_Function_Ptr; Num : Natural; Str : String) return Natural; @@ -46,10 +53,11 @@ package System.Val_Enum is -- other than those defined in package Standard. Names is a string with -- a lower bound of 1 containing the characters of all the enumeration -- literals concatenated together in sequence. Indexes is the address - -- of an array of type array (0 .. N) of Natural_8, where N is the + -- of an array of type array (0 .. N) of Index_Type, where N is the -- number of enumeration literals in the type. The Indexes values are -- the starting subscript of each enumeration literal, indexed by Pos -- values, with an extra entry at the end containing Names'Length + 1. + -- The parameter Hash is a (perfect) hash function for Names and Indexes. -- The parameter Num is the value N - 1 (i.e. Enum'Pos (Enum'Last)). -- The reason that Indexes is passed by address is that the actual type -- is created on the fly by the expander. @@ -59,22 +67,4 @@ package System.Val_Enum is -- If the image is found in Names, then the corresponding Pos value is -- returned. If not, Constraint_Error is raised. - function Value_Enumeration_16 - (Names : String; - Indexes : System.Address; - Num : Natural; - Str : String) - return Natural; - -- Identical to Value_Enumeration_8 except that it handles types - -- using array (0 .. Num) of Natural_16 for the Indexes table. - - function Value_Enumeration_32 - (Names : String; - Indexes : System.Address; - Num : Natural; - Str : String) - return Natural; - -- Identical to Value_Enumeration_8 except that it handles types - -- using array (0 .. Num) of Natural_32 for the Indexes table. - -end System.Val_Enum; +end System.Value_N; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 07820dba88aa..09d6b45bacb4 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -259,8 +259,9 @@ package Rtsfind is System_Img_Decimal_32, System_Img_Decimal_64, System_Img_Decimal_128, - System_Img_Enum, - System_Img_Enum_New, + System_Img_Enum_8, + System_Img_Enum_16, + System_Img_Enum_32, System_Img_Fixed_32, System_Img_Fixed_64, System_Img_Fixed_128, @@ -430,7 +431,9 @@ package Rtsfind is System_Val_Decimal_32, System_Val_Decimal_64, System_Val_Decimal_128, - System_Val_Enum, + System_Val_Enum_8, + System_Val_Enum_16, + System_Val_Enum_32, System_Val_Fixed_32, System_Val_Fixed_64, System_Val_Fixed_128, @@ -2663,9 +2666,11 @@ package Rtsfind is RE_Image_Decimal128 => System_Img_Decimal_128, - RE_Image_Enumeration_8 => System_Img_Enum_New, - RE_Image_Enumeration_16 => System_Img_Enum_New, - RE_Image_Enumeration_32 => System_Img_Enum_New, + RE_Image_Enumeration_8 => System_Img_Enum_8, + + RE_Image_Enumeration_16 => System_Img_Enum_16, + + RE_Image_Enumeration_32 => System_Img_Enum_32, RE_Image_Float => System_Img_Flt, @@ -3720,9 +3725,11 @@ package Rtsfind is RE_Value_Decimal128 => System_Val_Decimal_128, - RE_Value_Enumeration_8 => System_Val_Enum, - RE_Value_Enumeration_16 => System_Val_Enum, - RE_Value_Enumeration_32 => System_Val_Enum, + RE_Value_Enumeration_8 => System_Val_Enum_8, + + RE_Value_Enumeration_16 => System_Val_Enum_16, + + RE_Value_Enumeration_32 => System_Val_Enum_32, RE_Value_Fixed32 => System_Val_Fixed_32, diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 6b3027260b79..d198bdca0101 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -834,10 +834,13 @@ package body Sem_Attr is begin -- Access and Unchecked_Access are illegal in declare_expressions, - -- according to the RM. We also make the GNAT-specific - -- Unrestricted_Access attribute illegal. + -- according to the RM. We also make the GNAT Unrestricted_Access + -- attribute illegal if it comes from source. - if In_Declare_Expr > 0 then + if In_Declare_Expr > 0 + and then (Attr_Id /= Attribute_Unrestricted_Access + or else Comes_From_Source (N)) + then Error_Attr ("% attribute cannot occur in a declare_expression", N); end if;