synth: add partial support of foreign subprograms

8 files changed, 373 insertions, 8 deletions

diff --git a/Makefile.in b/Makefile.in
index 0176ce431..bbc7003d6 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -136,7 +136,7 @@ LIBVHDL_FLAGS_TO_PASS=\
  LN="$(LN)" CP="$(CP)" MKDIR="$(MKDIR)"
 
 # Object files from grt for the synthesis.
-GRT_SYNTH_OBJS=grt-cstdio.o
+GRT_SYNTH_OBJS=grt-cstdio.o grt-cdynload.o
 
 all: Makefile all.$(backend) all.libghdl all.ghw
 
@@ -277,6 +277,8 @@ copy-sources.gcc: version.ads scripts/gcc/Make-lang.in
 	$(CP) -p $(srcdir)/src/grt/grt-strings.ad? $(gcc_vhdl_dir)
 	$(CP) -p $(srcdir)/src/grt/grt-severity.ads $(gcc_vhdl_dir)
 	$(CP) -p $(srcdir)/src/grt/grt-readline_*.ad? $(gcc_vhdl_dir)
+	$(CP) -p $(srcdir)/src/grt/grt-dynload.ad? $(gcc_vhdl_dir)
+	$(CP) -p $(srcdir)/src/grt/grt-cdynload.c $(gcc_vhdl_dir)
 	$(CP) -p $(srcdir)/src/ortho/*.ad? $(gcc_vhdl_dir)
 	$(CP) -p $(srcdir)/src/ortho/gcc/*.ad? $(gcc_vhdl_dir)
 	$(CP) -p $(srcdir)/src/ortho/gcc/*.c $(gcc_vhdl_dir)
@@ -430,9 +432,11 @@ uninstall.llvm: uninstall.llvm.program uninstall.grt
 
 GHDL_SIMUL_INCFLAGS=$(GHDL_COMMON_INCFLAGS) -aI$(srcdir)/src/ghdldrv -aI$(srcdir)/src/simul -aI$(srcdir)/src/synth
 
+GRT_SIMUL_OBJS=$(GRT_C_OBJS) grt-cdynload.o
+
 ghdl_simul$(EXEEXT): GRT_FLAGS+=-DWITH_GNAT_RUN_TIME
-ghdl_simul$(EXEEXT): $(GRT_ADD_OBJS) $(GRT_SRC_DEPS) version.ads force
-	$(GNATMAKE) $(GHDL_SIMUL_INCFLAGS) $(GNATFLAGS) -gnat12 ghdl_simul $(GNAT_BARGS) -largs $(LDFLAGS) $(GRT_C_OBJS) $(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB)) $(sundials_ldflags)
+ghdl_simul$(EXEEXT): $(GRT_SIMUL_OBJS) $(GRT_SRC_DEPS) version.ads force
+	$(GNATMAKE) $(GHDL_SIMUL_INCFLAGS) $(GNATFLAGS) -gnat12 ghdl_simul $(GNAT_BARGS) -largs $(LDFLAGS) $(GRT_SIMUL_OBJS) $(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB)) $(sundials_ldflags)
 
 libs.vhdl.simul: ghdl_simul$(EXEEXT)
 	$(MAKE) -f $(srcdir)/libraries/Makefile.inc $(LIBVHDL_FLAGS_TO_PASS) GHDL=$(PWD)/ghdl_simul$(EXEEXT) GHDL_FLAGS="" VHDLLIBS_COPY_OBJS=no vhdl.libs.all
@@ -454,7 +458,7 @@ LIBGHDL_INCFLAGS=$(GHDL_COMMON_INCFLAGS) -aI$(srcdir)/src/synth -aI$(srcdir)/src
 
 libghdl_name=libghdl-$(libghdl_version)$(SOEXT)
 
-LIBGHDL_GRT_OBJS= pic/grt-cstdio.o
+LIBGHDL_GRT_OBJS= pic/grt-cstdio.o pic/grt-cdynload.o
 
 lib/$(libghdl_name): $(GRT_SRC_DEPS) $(LIBGHDL_GRT_OBJS) version.ads force
 #	Use -g for gnatlink so that the binder file is not removed.  We need
diff --git a/scripts/gcc/Make-lang.in.in b/scripts/gcc/Make-lang.in.in
index cdea74be8..26737ef07 100644
--- a/scripts/gcc/Make-lang.in.in
+++ b/scripts/gcc/Make-lang.in.in
@@ -51,7 +51,7 @@ vhdl VHDL: ghdl1$(exeext) ghdl$(exeext)
 # Tell GNU Make to ignore these, if they exist.
 .PHONY: vhdl VHDL
 
-GHDL1_OBJS = attribs.o vhdl/ortho-lang.o vhdl/grt-cstdio.o
+GHDL1_OBJS = attribs.o vhdl/ortho-lang.o vhdl/grt-cstdio.o vhdl/grt-cdynload.o
 
 # To be put in ALL_HOST_FRONTEND_OBJS, so that generated files are created
 # before.
@@ -117,7 +117,7 @@ vhdl/default_paths.ads: Makefile
 	echo "end Default_Paths;" >> tmp-dpaths.ads
 	$(srcdir)/../move-if-change tmp-dpaths.ads $@
 
-GHDL_GRT_OBJS=vhdl/grt-cstdio.o
+GHDL_GRT_OBJS=vhdl/grt-cstdio.o vhdl/grt-cdynload.o
 
 # The driver for ghdl.  Depends on ghdl1 to use object files in vhdl/ subdir.
 ghdl$(exeext): ghdl1$(exeext) $(GHDL_GRT_OBJS) vhdl/default_paths.ads force
diff --git a/src/ghdldrv/ghdlsimul.adb b/src/ghdldrv/ghdlsimul.adb
index 909253e60..a1f315678 100644
--- a/src/ghdldrv/ghdlsimul.adb
+++ b/src/ghdldrv/ghdlsimul.adb
@@ -52,6 +52,7 @@ with Elab.Debugger;
 
 with Synth.Flags;
 with Synth.Errors;
+with Synth.Vhdl_Foreign;
 with Simul.Vhdl_Elab;
 with Simul.Vhdl_Simul;
 
@@ -136,6 +137,7 @@ package body Ghdlsimul is
       --  Set flags.
       Synth.Flags.Flag_Simulation := True;
       Synth.Errors.Debug_Handler := Elab.Debugger.Debug_Error'Access;
+      Synth.Vhdl_Foreign.Initialize;
 
       --  Generic overriding.
       Top := Vhdl.Utils.Get_Entity_From_Configuration (Config);
diff --git a/src/ghdldrv/ghdlsynth.adb b/src/ghdldrv/ghdlsynth.adb
index df7d84231..44d553150 100644
--- a/src/ghdldrv/ghdlsynth.adb
+++ b/src/ghdldrv/ghdlsynth.adb
@@ -55,6 +55,7 @@ with Synthesis;
 with Synth.Disp_Vhdl;
 with Synth.Vhdl_Context;
 with Synth.Flags; use Synth.Flags;
+with Synth.Vhdl_Foreign;
 
 package body Ghdlsynth is
    type Out_Format is
@@ -566,6 +567,7 @@ package body Ghdlsynth is
          Res := No_Module;
       else
          Netlists.Errors.Initialize;
+         Synth.Vhdl_Foreign.Initialize;
          Res := Synthesis.Synth_Design (Config, Inst, Cmd.Top_Encoding);
       end if;
 
@@ -597,5 +599,6 @@ package body Ghdlsynth is
       Errorout.Console.Install_Handler;
       Options.Initialize;
       Netlists.Errors.Initialize;
+      Synth.Vhdl_Foreign.Initialize;
    end Init_For_Ghdl_Synth;
 end Ghdlsynth;
diff --git a/src/grt/grt-cdynload.c b/src/grt/grt-cdynload.c
index af595f454..493679759 100644
--- a/src/grt/grt-cdynload.c
+++ b/src/grt/grt-cdynload.c
@@ -1,5 +1,10 @@
 #if defined(__WIN32__)
 #include <windows.h>
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
 void *
 grt_dynload_open (const char *path)
 {
@@ -28,10 +33,18 @@ grt_dynload_error (void)
   return msg;
 }
 
+#ifdef __cplusplus
+}
+#endif
+
 #else
 
 #include <dlfcn.h>
 
+#ifdef __cplusplus
+extern "C" {
+#endif
+
 void *
 grt_dynload_open (const char *path)
 {
@@ -49,4 +62,8 @@ grt_dynload_error (void)
 {
   return dlerror ();
 }
+
+#ifdef __cplusplus
+}
+#endif
 #endif
diff --git a/src/synth/synth-vhdl_foreign.adb b/src/synth/synth-vhdl_foreign.adb
new file mode 100644
index 000000000..6e928761b
--- /dev/null
+++ b/src/synth/synth-vhdl_foreign.adb
@@ -0,0 +1,307 @@
+--  Foreign subprogram calls.
+--  Copyright (C) 2023 Tristan Gingold
+--
+--  This file is part of GHDL.
+--
+--  This program 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 of the License, or
+--  (at your option) any later version.
+--
+--  This program 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 this program.  If not, see <gnu.org/licenses>.
+
+with System; use System;
+with Ada.Unchecked_Conversion;
+
+with Hash; use Hash;
+with Interning;
+with Types; use Types;
+
+with Vhdl.Errors; use Vhdl.Errors;
+with Vhdl.Back_End; use Vhdl.Back_End;
+
+with Elab.Memtype; use Elab.Memtype;
+with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes;
+with Synth.Errors; use Synth.Errors;
+
+with Grt.Types; use Grt.Types;
+with Grt.Dynload; use Grt.Dynload;
+
+package body Synth.Vhdl_Foreign is
+
+   --  Cache of shlib to handle.
+   --  This is used to avoid calling dlopen multiple times.
+
+   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);
+
+   --  Cache of node to subprogram address.
+   --  Avoid multiple lookups (and decoding of FOREIGN value).
+   --  TODO: maybe also cache the caller ?
+
+   type Sym_Object_Type is record
+      N : Node;
+      Handler : Address;
+   end record;
+
+   function Sym_Build (N : Node) return Sym_Object_Type
+   is
+      Info : Foreign_Info_Type;
+      Handler : Address;
+   begin
+      Info := Translate_Foreign_Id (N);
+
+      if Info.Kind /= Foreign_Vhpidirect then
+         return (N => N,
+                 Handler => Null_Address);
+      end if;
+
+      declare
+         Lib : constant String :=
+           Info.Lib_Name (1 .. Info.Lib_Len);
+         Shlib : Shlib_Object_Type;
+      begin
+         if Info.Lib_Len = 0 or else Lib = "null" then
+            return (N => N,
+                    Handler => Null_Address);
+         end if;
+
+         Shlib := Shlib_Interning.Get (Lib);
+         if Shlib.Handler = Null_Address then
+            return (N => N,
+                    Handler => Null_Address);
+         end if;
+
+         Info.Subprg_Name (Info.Subprg_Len + 1) := NUL;
+
+         Handler := Grt_Dynload_Symbol
+           (Shlib.Handler,
+            Grt.Types.To_Ghdl_C_String (Info.Subprg_Name'Address));
+
+         return (N => N,
+                 Handler => Handler);
+      end;
+   end Sym_Build;
+
+   function Sym_Equal (Obj : Sym_Object_Type; N : Node) return Boolean is
+   begin
+      return Obj.N = N;
+   end Sym_Equal;
+
+   function Sym_Hash (N : Node) return Hash_Value_Type is
+   begin
+      return Hash_Value_Type (N);
+   end Sym_Hash;
+
+   package Sym_Interning is new Interning
+     (Params_Type => Node,
+      Object_Type => Sym_Object_Type,
+      Hash => Sym_Hash,
+      Build => Sym_Build,
+      Equal => Sym_Equal);
+
+   --  Classify a type; this determines the profile of the function.
+   type Type_Class is (Class_I32, Class_Unknown);
+
+   type Type_Class_Array is array (Nat32 range <>) of Type_Class;
+
+   function Classify (T : Type_Acc) return Type_Class is
+   begin
+      case T.Kind is
+         when Type_Discrete =>
+            if T.Sz = 4 then
+               return Class_I32;
+            end if;
+         when others =>
+            null;
+      end case;
+      return Class_Unknown;
+   end Classify;
+
+   --  Callers for each profile.
+   --  This doesn't scale!
+
+   --  For functions that returns an int32 and no arguments.
+   procedure Call_I32 (Args : Valtyp_Array;
+                       Res : Memory_Ptr;
+                       Handler : Address)
+   is
+      pragma Assert (Args'Length = 0);
+      type Proto_Acc is access function return Ghdl_I32;
+      pragma Convention (C, Proto_Acc);
+      function To_Proto_Acc is new Ada.Unchecked_Conversion
+        (Address, Proto_Acc);
+      Proto : constant Proto_Acc := To_Proto_Acc (Handler);
+      R : Ghdl_I32;
+   begin
+      R := Proto.all;
+      Write_I32 (Res, R);
+   end Call_I32;
+
+   type Call_Acc is access procedure (Args : Valtyp_Array;
+                                      Res : Memory_Ptr;
+                                      Handler : Address);
+
+
+   --  Association between a profile and the call function.
+   type Profile_Record is record
+      Nargs : Nat32;
+      Args : Type_Class_Array (1 .. 4);
+      Res : Type_Class;
+      Call : Call_Acc;
+   end record;
+
+   function Profile_Match (L, R : Profile_Record) return Boolean is
+   begin
+      if L.Nargs /= R.Nargs
+        or else L.Res /= R.Res
+      then
+         return False;
+      end if;
+      for J in 1 .. L.Nargs loop
+         if L.Args (J) /= R.Args (J) then
+            return False;
+         end if;
+      end loop;
+      return True;
+   end Profile_Match;
+
+   --  List of known/implemented profile.
+   type Profile_Array is array (Natural range <>) of Profile_Record;
+
+   Profiles : constant Profile_Array :=
+     (1 => (Nargs => 0,
+            Args => (others => Class_Unknown),
+            Res => Class_I32,
+            Call => Call_I32'Access));
+
+   function Call_Subprogram (Syn_Inst : Synth_Instance_Acc;
+                             Sub_Inst : Synth_Instance_Acc;
+                             Imp      : Node;
+                             Loc : Node) return Valtyp
+   is
+      Args : Valtyp_Array (1 .. 4);
+      Ret_Typ : Type_Acc;
+      Inter : Node;
+      Sym : Sym_Object_Type;
+      Profile : Profile_Record;
+      Res : Valtyp;
+      Res_Mem : Memory_Ptr;
+   begin
+      --  Find the handle.
+      Sym := Sym_Interning.Get (Imp);
+      if Sym.Handler = Null_Address then
+         Error_Msg_Synth (Sub_Inst, Loc, "cannot load FOREIGN %n", +Imp);
+         return No_Valtyp;
+      end if;
+
+      --  Determine the profile.
+      Inter := Get_Interface_Declaration_Chain (Imp);
+      Profile.Nargs := 0;
+      Profile.Args := (others => Class_Unknown);
+      Profile.Call := null;
+      while Inter /= Null_Node loop
+         declare
+            C : Type_Class;
+            Val : Valtyp;
+         begin
+            Profile.Nargs := Profile.Nargs + 1;
+            Val := Get_Value (Sub_Inst, Inter);
+            C := Classify (Val.Typ);
+            if C = Class_Unknown then
+               Error_Msg_Synth
+                 (Syn_Inst, Loc,
+                  "unhandled type for interface %n of FOREIGN %n",
+                  (+Inter, +Imp));
+               return No_Valtyp;
+            end if;
+            Profile.Args (Profile.Nargs) := C;
+            Args (Profile.Nargs) := Val;
+         end;
+         Inter := Get_Chain (Inter);
+      end loop;
+
+      case Iir_Kinds_Subprogram_Declaration (Get_Kind (Imp)) is
+         when Iir_Kind_Function_Declaration =>
+            Ret_Typ := Get_Subtype_Object (Syn_Inst, Get_Return_Type (Imp));
+            Profile.Res := Classify (Ret_Typ);
+            if Profile.Res = Class_Unknown then
+               Error_Msg_Synth
+                 (Syn_Inst, Loc,
+                  "unhandled type for result of FOREIGN %n", +Imp);
+               return No_Valtyp;
+            end if;
+
+         when Iir_Kind_Procedure_Declaration =>
+            Ret_Typ := null;
+            Profile.Res := Class_Unknown;
+      end case;
+
+      --  Find the profile.
+      for I in Profiles'Range loop
+         if Profile_Match (Profiles (I), Profile) then
+            Profile.Call := Profiles (I).Call;
+            exit;
+         end if;
+      end loop;
+
+      if Profile.Call = null then
+         Error_Msg_Synth
+           (Syn_Inst, Loc, "unhandled caller for FOREIGN %n", +Imp);
+         return No_Valtyp;
+      end if;
+
+      --  Allocate result.
+      if Ret_Typ = null then
+         Res := No_Valtyp;
+         Res_Mem := null;
+      else
+         Res := Create_Value_Memory (Ret_Typ, Expr_Pool'Access);
+         Res_Mem := Get_Memory (Res);
+      end if;
+
+      --  Call.
+      Profile.Call.all (Args (1 .. Profile.Nargs), Res_Mem, Sym.Handler);
+
+      return Res;
+   end Call_Subprogram;
+
+   procedure Initialize is
+   begin
+      Shlib_Interning.Init;
+      Sym_Interning.Init;
+   end Initialize;
+end Synth.Vhdl_Foreign;
diff --git a/src/synth/synth-vhdl_foreign.ads b/src/synth/synth-vhdl_foreign.ads
new file mode 100644
index 000000000..396da3fe0
--- /dev/null
+++ b/src/synth/synth-vhdl_foreign.ads
@@ -0,0 +1,31 @@
+--  Foreign subprogram calls.
+--  Copyright (C) 2023 Tristan Gingold
+--
+--  This file is part of GHDL.
+--
+--  This program 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 of the License, or
+--  (at your option) any later version.
+--
+--  This program 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 this program.  If not, see <gnu.org/licenses>.
+
+with Vhdl.Nodes; use Vhdl.Nodes;
+
+with Elab.Vhdl_Context; use Elab.Vhdl_Context;
+with Elab.Vhdl_Values; use Elab.Vhdl_Values;
+
+package Synth.Vhdl_Foreign is
+   function Call_Subprogram (Syn_Inst : Synth_Instance_Acc;
+                             Sub_Inst : Synth_Instance_Acc;
+                             Imp      : Node;
+                             Loc : Node) return Valtyp;
+
+   procedure Initialize;
+end Synth.Vhdl_Foreign;
diff --git a/src/synth/synth-vhdl_stmts.adb b/src/synth/synth-vhdl_stmts.adb
index cd93c3673..52f08ce86 100644
--- a/src/synth/synth-vhdl_stmts.adb
+++ b/src/synth/synth-vhdl_stmts.adb
@@ -53,6 +53,7 @@ with Synth.Vhdl_Decls; use Synth.Vhdl_Decls;
 with Synth.Vhdl_Expr; use Synth.Vhdl_Expr;
 with Synth.Vhdl_Insts; use Synth.Vhdl_Insts;
 with Synth.Vhdl_Eval;
+with Synth.Vhdl_Foreign;
 with Synth.Source;
 with Synth.Vhdl_Static_Proc;
 with Synth.Flags;
@@ -2773,8 +2774,8 @@ package body Synth.Vhdl_Stmts is
       C : Seq_Context (Mode_Static);
    begin
       if Get_Foreign_Flag (Imp) then
-         Error_Msg_Synth (Syn_Inst, Loc, "cannot call FOREIGN %n", +Imp);
-         return No_Valtyp;
+         return Synth.Vhdl_Foreign.Call_Subprogram
+           (Syn_Inst, Sub_Inst, Imp, Loc);
       end if;
 
       C := (Mode_Static,