synth: add partial support of foreign subprograms

3 files changed, 341 insertions, 2 deletions

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,