From e857941acd16e3a678296b26e34b4bf330d5239c Mon Sep 17 00:00:00 2001
From: Tristan Gingold <tgingold@free.fr>
Date: Sat, 27 Apr 2019 10:14:26 +0200
Subject: vhdl: supports VHPIDIRECT in mcode backend.

src: add hash.ad[sb], interning.ad[sb]
Automatically link with vhpidirect libraries.
---
 src/ghdldrv/ghdldrv.adb |  7 +++--
 src/ghdldrv/ghdlrun.adb | 75 +++++++++++++++++++++++++++++++++++++++++++++----
 2 files changed, 74 insertions(+), 8 deletions(-)

(limited to 'src/ghdldrv')

diff --git a/src/ghdldrv/ghdldrv.adb b/src/ghdldrv/ghdldrv.adb
index e77bfb8f4..cdec0eca6 100644
--- a/src/ghdldrv/ghdldrv.adb
+++ b/src/ghdldrv/ghdldrv.adb
@@ -315,6 +315,7 @@ package body Ghdldrv is
       Free (Obj_File);
    end Do_Compile;
 
+   --  Table of files to be linked.
    package Filelist is new Tables
      (Table_Component_Type => String_Access,
       Table_Index_Type => Natural,
@@ -383,6 +384,9 @@ package body Ghdldrv is
             if Line (1) = '>' then
                Dir_Len := L - 1;
                Dir (1 .. Dir_Len) := Line (2 .. L);
+            elsif Line (1) = '+' then
+               File := new String'(Line (2 .. L));
+               Filelist.Append (File);
             else
                if To_Obj then
                   File := new String'(Dir (1 .. Dir_Len)
@@ -392,8 +396,7 @@ package body Ghdldrv is
                   File := new String'(Substitute (Line (1 .. L)));
                end if;
 
-               Filelist.Increment_Last;
-               Filelist.Table (Filelist.Last) := File;
+               Filelist.Append (File);
 
                Dir_Len := 0;
             end if;
diff --git a/src/ghdldrv/ghdlrun.adb b/src/ghdldrv/ghdlrun.adb
index 3501bb692..fbe10c5d3 100644
--- a/src/ghdldrv/ghdlrun.adb
+++ b/src/ghdldrv/ghdlrun.adb
@@ -44,12 +44,15 @@ with Ieee.Std_Logic_1164;
 
 with Lists;
 with Str_Table;
+with Hash;
+with Interning;
 with Nodes;
 with Files_Map;
 with Name_Table;
 
 with Grt.Main;
 with Grt.Modules;
+with Grt.Dynload; use Grt.Dynload;
 with Grt.Lib;
 with Grt.Processes;
 with Grt.Rtis;
@@ -80,6 +83,36 @@ package body Ghdlrun is
    --  Default elaboration mode is dynamic.
    Elab_Mode : constant Elab_Mode_Type := Elab_Dynamic;
 
+   type Shlib_Object_Type is record
+      Name : String_Access;
+      Handler : Address;
+   end record;
+
+   function Shlib_Build (Name : String) return Shlib_Object_Type
+   is
+      Name_Acc : constant String_Access := new String'(Name);
+      C_Name : constant String := Name & Nul;
+      Handler : Address;
+   begin
+      Handler :=
+        Grt_Dynload_Open (Grt.Types.To_Ghdl_C_String (C_Name'Address));
+      return (Name => Name_Acc,
+              Handler => Handler);
+   end Shlib_Build;
+
+   function Shlib_Equal (Obj : Shlib_Object_Type; Param : String)
+                        return Boolean is
+   begin
+      return Obj.Name.all = Param;
+   end Shlib_Equal;
+
+   package Shlib_Interning is new Interning
+     (Params_Type => String,
+      Object_Type => Shlib_Object_Type,
+      Hash => Hash.String_Hash,
+      Build => Shlib_Build,
+      Equal => Shlib_Equal);
+
    procedure Foreign_Hook (Decl : Iir;
                            Info : Translation.Foreign_Info_Type;
                            Ortho : O_Dnode);
@@ -103,6 +136,7 @@ package body Ghdlrun is
       end if;
 
       Translation.Foreign_Hook := Foreign_Hook'Access;
+      Shlib_Interning.Init;
 
       --  FIXME: add a flag to force unnesting.
       --  Translation.Flag_Unnest_Subprograms := True;
@@ -174,7 +208,7 @@ package body Ghdlrun is
          when Elab_Static =>
             raise Program_Error;
          when Elab_Dynamic =>
-            Translation.Elaborate (Config, "", True);
+            Translation.Elaborate (Config, True);
       end case;
 
       if Errorout.Nbr_Errors > 0 then
@@ -241,14 +275,43 @@ package body Ghdlrun is
             declare
                Name : constant String :=
                  Info.Subprg_Name (1 .. Info.Subprg_Len);
+               Lib : constant String :=
+                 Info.Lib_Name (1 .. Info.Lib_Len);
+               Shlib : Shlib_Object_Type;
             begin
-               Res := Foreigns.Find_Foreign (Name);
-               if Res /= Null_Address then
-                  Def (Ortho, Res);
+               if Info.Lib_Len = 0
+                 or else Lib = "null"
+               then
+                  Res := Foreigns.Find_Foreign (Name);
+                  if Res = Null_Address then
+                     Error_Msg_Sem
+                       (+Decl, "unknown foreign VHPIDIRECT '" & Name & "'");
+                     return;
+                  end if;
                else
-                  Error_Msg_Sem
-                    (+Decl, "unknown foreign VHPIDIRECT '" & Name & "'");
+                  Shlib := Shlib_Interning.Get (Lib);
+                  if Shlib.Handler = Null_Address then
+                     Error_Msg_Sem
+                       (+Decl, "cannot load VHPIDIRECT shared library '" &
+                          Lib & "'");
+                     return;
+                  end if;
+
+                  declare
+                     C_Name : constant String := Name & Nul;
+                  begin
+                     Res := Grt_Dynload_Symbol
+                       (Shlib.Handler,
+                        Grt.Types.To_Ghdl_C_String (C_Name'Address));
+                  end;
+                  if Res = Null_Address then
+                     Error_Msg_Sem
+                       (+Decl, "cannot resolve VHPIDIRECT symbol '"
+                          & Name & "'");
+                     return;
+                  end if;
                end if;
+               Def (Ortho, Res);
             end;
          when Foreign_Intrinsic =>
 
-- 
cgit v1.2.3