Add commands to build vpi modules (WIP)

7 files changed, 263 insertions, 9 deletions

diff --git a/src/ghdldrv/default_pathes.ads.in b/src/ghdldrv/default_pathes.ads.in
index 7f471a5ed..a7c3d15f7 100644
--- a/src/ghdldrv/default_pathes.ads.in
+++ b/src/ghdldrv/default_pathes.ads.in
@@ -36,4 +36,7 @@ package Default_Pathes is
      "@COMPILER_DEBUG@";
    Post_Processor : constant String :=
      "@POST_PROCESSOR@";
+
+   Shared_Library_Extension : constant String :=
+     "@SOEXT@";
 end Default_Pathes;
diff --git a/src/ghdldrv/ghdl_jit.adb b/src/ghdldrv/ghdl_jit.adb
index ba7087492..d80b7a4f8 100644
--- a/src/ghdldrv/ghdl_jit.adb
+++ b/src/ghdldrv/ghdl_jit.adb
@@ -19,6 +19,7 @@ with Ghdlmain;
 with Ghdllocal;
 with Ghdlprint;
 with Ghdlrun;
+with Ghdlvpi;
 with Ortho_Jit;
 
 procedure Ghdl_Jit is
@@ -28,6 +29,7 @@ begin
    Ghdlmain.Version_String :=
      new String'(Ortho_Jit.Get_Jit_Name & " code generator");
    Ghdlrun.Register_Commands;
+   Ghdlvpi.Register_Commands;
    Ghdllocal.Register_Commands;
    Ghdlprint.Register_Commands;
    Ghdlmain.Register_Commands;
diff --git a/src/ghdldrv/ghdllocal.adb b/src/ghdldrv/ghdllocal.adb
index 15facb867..906bdc046 100644
--- a/src/ghdldrv/ghdllocal.adb
+++ b/src/ghdldrv/ghdllocal.adb
@@ -198,6 +198,11 @@ package body Ghdllocal is
       return Pathname'First - 1;
    end Get_Basename_Pos;
 
+   function Is_Basename (Pathname : String) return Boolean is
+   begin
+      return Get_Basename_Pos (Pathname) < Pathname'First;
+   end Is_Basename;
+
    --  Simple lower case conversion, used to compare with "bin".
    function To_Lower (S : String) return String
    is
@@ -336,7 +341,7 @@ package body Ghdllocal is
 
       --  If the command name is a relative path, deduce prefix from it
       --  and current path.
-      if Get_Basename_Pos (Prog_Path) >= Prog_Path'First then
+      if not Is_Basename (Prog_Path) then
          if Is_Executable_File (Prog_Path) then
             Set_Prefix_From_Program_Path
               (Get_Current_Dir & Directory_Separator & Prog_Path);
diff --git a/src/ghdldrv/ghdllocal.ads b/src/ghdldrv/ghdllocal.ads
index 43f2de8cb..0809035b1 100644
--- a/src/ghdldrv/ghdllocal.ads
+++ b/src/ghdldrv/ghdllocal.ads
@@ -78,6 +78,11 @@ package Ghdllocal is
    --  if none.
    function Get_Basename_Pos (Pathname : String) return Natural;
 
+   --  Return TRUE iff PATHNAME is a command name: a path name without path
+   --  component.  Usually these command names must be search on the command
+   --  path (PATH).
+   function Is_Basename (Pathname : String) return Boolean;
+
    --  Build a filename based on FILE. If IN_WORK is true, the result is
    --  the concatenation of the workdir, the basename of FILE and SUFFIX.
    --  If IN_WORK is false, the result is the concatenation of FILE and SUFFIX.
@@ -104,6 +109,9 @@ package Ghdllocal is
    --  Setup standard libaries path.  If LOAD is true, then load them now.
    procedure Setup_Libraries (Load : Boolean);
 
+   --  Set Exec_Prefix from program name.  Called by Setup_Libraries.
+   procedure Set_Exec_Prefix;
+
    --  Setup library, analyze FILES, and if SAVE_LIBRARY is set save the
    --  work library only
    procedure Analyze_Files (Files : Argument_List; Save_Library : Boolean);
diff --git a/src/ghdldrv/ghdlvpi.adb b/src/ghdldrv/ghdlvpi.adb
new file mode 100644
index 000000000..12edcb2d5
--- /dev/null
+++ b/src/ghdldrv/ghdlvpi.adb
@@ -0,0 +1,211 @@
+--  GHDL driver - compile and link wrappers for VPI.
+--  Copyright (C) 2016 Tristan Gingold
+--
+--  GHDL is free software; you can redistribute it and/or modify it under
+--  the terms of the GNU General Public License as published by the Free
+--  Software Foundation; either version 2, or (at your option) any later
+--  version.
+--
+--  GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+--  WARRANTY; without even the implied warranty of MERCHANTABILITY or
+--  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+--  for more details.
+--
+--  You should have received a copy of the GNU General Public License
+--  along with GCC; see the file COPYING.  If not, write to the Free
+--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+--  02111-1307, USA.
+
+with Ada.Text_IO; use Ada.Text_IO;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Ada.Command_Line; use Ada.Command_Line;
+with Ghdlmain; use Ghdlmain;
+with Ghdllocal;
+with Default_Pathes;
+
+package body Ghdlvpi is
+
+   --  A command that accepts '-v'.
+   type Command_Flag_Type is abstract new Command_Type with record
+      Flag_Verbose : Boolean := False;
+   end record;
+
+   procedure Decode_Option (Cmd : in out Command_Flag_Type;
+                            Option : String;
+                            Arg : String;
+                            Res : out Option_Res);
+
+   procedure Decode_Option (Cmd : in out Command_Flag_Type;
+                            Option : String;
+                            Arg : String;
+                            Res : out Option_Res)
+   is
+      pragma Unreferenced (Arg);
+   begin
+      if Option = "-v" then
+         Cmd.Flag_Verbose := True;
+         Res := Option_Ok;
+      else
+         Res := Option_Bad;
+      end if;
+   end Decode_Option;
+
+   --  Return the include directory.
+   function Get_Vpi_Include_Dir return String is
+   begin
+      --  Compute install path
+      Ghdllocal.Set_Exec_Prefix;
+
+      return Ghdllocal.Exec_Prefix.all & Directory_Separator & "include";
+   end Get_Vpi_Include_Dir;
+
+   --  Return the include directory.
+   function Get_Vpi_Lib_Dir return String is
+   begin
+      if Ghdllocal.Exec_Prefix = null then
+         --  Compute install path (only once).
+         Ghdllocal.Set_Exec_Prefix;
+      end if;
+
+      return Ghdllocal.Exec_Prefix.all & Directory_Separator & "lib";
+   end Get_Vpi_Lib_Dir;
+
+   procedure Spawn_Compile (User_Args : Argument_List;
+                            Extra_Args : Argument_List;
+                            Verbose : Boolean)
+   is
+      Cargs : Argument_List (1 .. User_Args'Length + Extra_Args'Length);
+      Program_Name : String_Access;
+      Nbr_Args : Natural;
+      Status : Integer;
+   begin
+      Nbr_Args := 0;
+
+      --  Extract compiler name.
+      if User_Args'First > User_Args'Last then
+         Error ("missing compiler name");
+      else
+         Program_Name := User_Args (User_Args'First);
+         if Ghdllocal.Is_Basename (Program_Name.all) then
+            --  For a command name (without path component), search on the
+            --  path.
+            Program_Name := Locate_Exec_On_Path (Program_Name.all);
+         else
+            --  For a relative or absolute path, use the path directly.
+            null;
+         end if;
+      end if;
+
+      --  Copy user args.
+      for I in User_Args'First + 1 .. User_Args'Last loop
+         Nbr_Args := Nbr_Args + 1;
+         Cargs (Nbr_Args) := User_Args (I);
+      end loop;
+
+      --  Copy extra args.
+      for I in Extra_Args'Range loop
+         Nbr_Args := Nbr_Args + 1;
+         Cargs (Nbr_Args) := Extra_Args (I);
+      end loop;
+
+      --  Display command (if verbose)
+      if Verbose then
+         Put (Program_Name.all);
+         for I in Cargs'First .. Nbr_Args loop
+            Put (' ');
+            Put (Cargs (I).all);
+         end loop;
+         New_Line;
+      end if;
+
+      --  Execute command
+      Status := Spawn (Program_Name.all, Cargs (Cargs'First .. Nbr_Args));
+      Set_Exit_Status (Exit_Status (Status));
+   end Spawn_Compile;
+
+   --  Command --vpi-compile
+   type Command_Vpi_Compile is new Command_Flag_Type with null record;
+   function Decode_Command (Cmd : Command_Vpi_Compile; Name : String)
+                           return Boolean;
+   function Get_Short_Help (Cmd : Command_Vpi_Compile) return String;
+   procedure Perform_Action (Cmd : in out Command_Vpi_Compile;
+                             Args : Argument_List);
+
+   function Decode_Command (Cmd : Command_Vpi_Compile; Name : String)
+                           return Boolean
+   is
+      pragma Unreferenced (Cmd);
+   begin
+      return Name = "--vpi-compile";
+   end Decode_Command;
+
+   function Get_Short_Help (Cmd : Command_Vpi_Compile) return String
+   is
+      pragma Unreferenced (Cmd);
+   begin
+      return "--vpi-compile CMD ARGS     Compile with VPI include path";
+   end Get_Short_Help;
+
+   procedure Perform_Action (Cmd : in out Command_Vpi_Compile;
+                             Args : Argument_List)
+   is
+      Extra_Args : Argument_List (1 .. 1);
+   begin
+      Extra_Args (1) := new String'("-I" & Get_Vpi_Include_Dir);
+
+      Spawn_Compile (Args, Extra_Args, Cmd.Flag_Verbose);
+   end Perform_Action;
+
+   --  Command --vpi-link
+   type Command_Vpi_Link is new Command_Flag_Type with null record;
+   function Decode_Command (Cmd : Command_Vpi_Link; Name : String)
+                           return Boolean;
+   function Get_Short_Help (Cmd : Command_Vpi_Link) return String;
+   procedure Perform_Action (Cmd : in out Command_Vpi_Link;
+                             Args : Argument_List);
+
+   function Decode_Command (Cmd : Command_Vpi_Link; Name : String)
+                           return Boolean
+   is
+      pragma Unreferenced (Cmd);
+   begin
+      return Name = "--vpi-link";
+   end Decode_Command;
+
+   function Get_Short_Help (Cmd : Command_Vpi_Link) return String
+   is
+      pragma Unreferenced (Cmd);
+   begin
+      return "--vpi-link CMD ARGS     Link with VPI library";
+   end Get_Short_Help;
+
+   procedure Perform_Action (Cmd : in out Command_Vpi_Link;
+                             Args : Argument_List)
+   is
+      use Default_Pathes;
+      Is_Unix : constant Boolean := Shared_Library_Extension = ".so";
+      Is_Darwin : constant Boolean := Shared_Library_Extension = ".dylib";
+      Extra_Args : Argument_List (1 .. 4);
+      Nbr : Natural;
+   begin
+      Extra_Args (1) := new String'("--shared");
+      Extra_Args (2) := new String'("-L" & Get_Vpi_Lib_Dir);
+      Extra_Args (3) := new String'("-lghdlvpi");
+      Nbr := 3;
+
+      if Is_Unix or Is_Darwin then
+         --  On linux/unix, add rpath.
+         Nbr := Nbr + 1;
+         Extra_Args (Nbr) := new String'
+           ("-Wl,-rpath," & Get_Vpi_Lib_Dir);
+      end if;
+
+      Spawn_Compile (Args, Extra_Args (1 .. Nbr), Cmd.Flag_Verbose);
+   end Perform_Action;
+
+   procedure Register_Commands is
+   begin
+      Register_Command (new Command_Vpi_Compile);
+      Register_Command (new Command_Vpi_Link);
+   end Register_Commands;
+end Ghdlvpi;
diff --git a/src/ghdldrv/ghdlvpi.ads b/src/ghdldrv/ghdlvpi.ads
new file mode 100644
index 000000000..24eafbf78
--- /dev/null
+++ b/src/ghdldrv/ghdlvpi.ads
@@ -0,0 +1,20 @@
+--  GHDL driver - compile and link wrappers for VPI.
+--  Copyright (C) 2016 Tristan Gingold
+--
+--  GHDL is free software; you can redistribute it and/or modify it under
+--  the terms of the GNU General Public License as published by the Free
+--  Software Foundation; either version 2, or (at your option) any later
+--  version.
+--
+--  GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+--  WARRANTY; without even the implied warranty of MERCHANTABILITY or
+--  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+--  for more details.
+--
+--  You should have received a copy of the GNU General Public License
+--  along with GCC; see the file COPYING.  If not, write to the Free
+--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+--  02111-1307, USA.
+package Ghdlvpi is
+   procedure Register_Commands;
+end Ghdlvpi;
diff --git a/src/grt/grt-cvpi.c b/src/grt/grt-cvpi.c
index e122e1b4c..2a1a6cd36 100644
--- a/src/grt/grt-cvpi.c
+++ b/src/grt/grt-cvpi.c
@@ -130,18 +130,19 @@ module_error (void)
 }
 #endif
 
+#if defined (__APPLE__)
+/* On Darwin: look in rpath.  */
+#define LIBNAME "@rpath/libghdlvpi" DSO_EXT
+#else
+#define LIBNAME "libghdlvpi" DSO_EXT
+#endif
+
+static const char libghdlvpi_name[] = LIBNAME;
+
 int
 loadVpiModule (const char* modulename)
 {
-  static const char libghdlvpi_name[] = "@executable_path/libghdlvpi" DSO_EXT;
   static void *libghdlvpi_mod;
-
-  static const char * const vpitablenames[] =
-    {
-      "_vlog_startup_routines", // with leading underscore: MacOSX
-      "vlog_startup_routines"   // w/o  leading underscore: Linux
-    };
-
   int i;
   void *vpimod;
 
@@ -161,6 +162,10 @@ loadVpiModule (const char* modulename)
      No need to load the library several times.  */
   if (libghdlvpi_mod == NULL)
     {
+      /* TODO: on windows, use SetDllDirectory with:
+	 - install dir (libdir) => add -DLIBDIR=xxx
+	 - exec path\lib => see windows_default_path
+      */
       libghdlvpi_mod = module_open (libghdlvpi_name);
       if (libghdlvpi_mod != NULL)
 	{