Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--        G N A T . 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-2011, AdaCore                     --

--                                                                          --

-- GNAT is free software;  you can  redistribute it  and/or modify it under --

-- terms of the  GNU General Public License as published  by the Free Soft- --

-- ware  Foundation;  either version 3,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --

--                                                                          --

-- As a special exception under Section 7 of GPL version 3, you are granted --

-- additional permissions described in the GCC Runtime Library Exception,   --

-- version 3.1, as published by the Free Software Foundation.               --

--                                                                          --

-- You should have received a copy of the GNU General Public License and    --

-- a copy of the GCC Runtime Library Exception along with this program;     --

-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --

-- <http://www.gnu.org/licenses/>.                                          --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

with Ada.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;

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.

   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;

   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

   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 --

   ------------------------

   function Ada_File_Base_Name (Pkg_Name : String) return String is

   begin

      --  Convert to lower case, then replace '.' with '-'

      return Result : String := To_Lower (Pkg_Name) do

         for J in Result'Range loop

            if Result (J) = '.' then

               Result (J) := '-';

            end if;

         end loop;

      end return;

   end Ada_File_Base_Name;

   ---------

   -- 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

               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;

   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)