Converting Ada closures to C callbacks (function + void*)

Question

Most clean C APIs declare callback as a combination of callback function and a user data. User data is usually void*. WinAPI uses pointer-sized integer (lParam). During making a thick binding a natural desire is to allow Ada 2005 closures to be used in place of C callbacks.

I have a code. It works like a charm on GNAT (GPL 2012, x86-windows is tested at least), but generally there is no guarantee that Run_Closure_Adapter.X variable and Run_Closure.X argument will have the same internal structure.

The question is: is there a proper (standards-compliant) way to do this? Maybe a trick involving tagged types, interfaces or generics. There is at least one way of doing this: running closure executor and closures in different tasks and using rendezvous. But that's too slow.

Closure_Test.adb:

with Closure_Lib; use Closure_Lib;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;

procedure Closure_Test is

   procedure Closure_Tester is

      Local_String : String := "Hello, world!";

      procedure Closure is
      begin
         Put_Line (Local_String);
      end Closure;

   begin
      Run_Closure (Closure'Access);
   end Closure_Tester;

   procedure Ada_Run_Closure (X : access procedure) is
   begin
      X.all;
   end Ada_Run_Closure;

   -- Nested_Closure fills the execution stack with
   -- several activation records of Nested_Closure_Tester
   -- Having done so (local I = 0) we start a Fibonacci
   -- algorithm using Print_Closure access values of
   -- different dynamic nesting levels

   procedure Nested_Closure_Tester
     (I : Integer;
      Closure_Runner: access procedure (X : access procedure);
      Prev_Closure, Prev_Closure2: access procedure)
   is

      procedure Print_Closure is
      begin
         if Prev_Closure /= null and Prev_Closure2 /= null then
            Closure_Runner (Prev_Closure);
            Closure_Runner (Prev_Closure2);
         else
            Put (".");
         end if;
      end Print_Closure;

      procedure Nested_Closure is
      begin
         if I > 0 then
            Nested_Closure_Tester (I - 1, Closure_Runner,
                                   Print_Closure'Access, Prev_Closure);
         else
            Print_Closure;
         end if;
      end Nested_Closure;
   begin
      Closure_Runner (Nested_Closure'Access);
   end Nested_Closure_Tester;

begin
   -- Closure_Tester;
   -- I = 6 gives 13 dots
   Nested_Closure_Tester(6, Ada_Run_Closure'Access, null, null);
   New_Line;
   Nested_Closure_Tester(6, Run_Closure'Access, null, null);
end Closure_Test;

Closure_Lib.ads:

with Interfaces.C;
with System;

package Closure_Lib is

   procedure Run_Closure (X : access procedure);

private

   type Simple_Callback is access procedure(Data : in System.Address);
   pragma Convention (C, Simple_Callback);

   procedure Run_Callback (X : in Simple_Callback; Data : in System.Address);

   pragma Import (C, Run_Callback, "Run_Callback");

   procedure Sample_Callback (Data : in System.Address);
   pragma Convention (C, Sample_Callback);

end Closure_Lib;

Closure_Lib.adb:

with Interfaces.C;
with System;
with System.Storage_Elements; use System.Storage_Elements;
with Ada.Text_IO; use Ada.Text_IO;

package body Closure_Lib is

   procedure Sample_Callback (Data : in System.Address) is
   begin
      Ada.Text_IO.Put_Line ("Simple_Callback");
   end Sample_Callback;

   procedure Run_Closure_Adapter (Data : in System.Address);
   pragma Convention (C, Run_Closure_Adapter);

   procedure Run_Closure_Adapter (Data : in System.Address) is
      X : access procedure;
      for X'Address use Data;
      pragma Import (Ada, X);
      X_Size : constant Storage_Count := X'Size / System.Storage_Unit;
   begin
      -- Put_Line ("Variable access procedure size:" & Storage_Count'Image (X_Size));
      X.all;
   end Run_Closure_Adapter;

   procedure Run_Closure (X : access procedure) is
      X_Size : constant Storage_Count := X'Size / System.Storage_Unit;
      X_Address : constant System.Address := X'Address;
   begin
      -- Put_Line ("Anonymous access procedure size:" & Storage_Count'Image (X_Size));
      Run_Callback (Run_Closure_Adapter'Access, X_Address);
   end Run_Closure;

end Closure_Lib;

closure_executor.c:

typedef void (*Simple_Callback)(void* Data);

void Run_Callback (Simple_Callback X, void* Data) {
    (*X)(Data);
}

Answer 1

I think what you're looking for might be met by using a generic (by the way, I don't see how using a task can ensure that data types match?)

Maybe something like

generic
   type Client_Data is private;
package Closure_G is
   type Closure (<>) is private;
   function Create (Proc : access procedure (Parameter : Client_Data);
                    And_Parameter : Client_Data) return Closure;
   procedure Execute (The_Closure : Closure);
private
   type Procedure_P is access procedure (Parameter : Client_Data);
   type Closure is record
      The_Procedure : Procedure_P;
      And_Parameter : Client_Data;
   end record;
end Closure_G;

When a user calls Execute (A_Closure), the Proc supplied to Create is called with the And_Parameter that was supplied then.

(The type Closure (<>) is private; makes sure tht users can only create a Closure object using the supplied Create.)

The main trouble with this, in your scenario of passing to a C library to be called-back when an event occurs, is that the Closure object is actually maintained by the C library.

Aside from the fact that you don't really need this Ada Closure, there's a potential problem caused by anonymous access-to-subprogram values, which is that the subprogram could be locally declared and have gone out of scope by the time the C library gets round to calling it. This would be Bad News.

In the Ada world, the compiler copes with this problem in two ways. First, you're not allowed to store anonymous access-to-subprogram values (hence the type Procedure_P above). Second, even if you work round this as in

function Create (Proc : access procedure (Parameter : Client_Data);
                 And_Parameter : Client_Data) return Closure is
begin
   return (The_Procedure => Procedure_P'(Proc),
           And_Parameter => And_Parameter);
end Create;

the actual 'accessibility levels' are checked at run time; if you get it wrong you'll get a Program_Error.

Answer 2

As an alternative, you might look at how GtkAda handles callbacks from GTK+. As shown in the GtkAda User’s Guide, and discussed in §4.2.2. Connecting via the Gtk.Handlers package,

The Gtk.Marshallers package provides a set of functions that can be used as callbacks directly for GtkAda…A set of To_Marshaller functions is found in every generic package in Gtk.Handlers. They take a single argument, the name of the function you want to call, and return a handler that can be used directly in Connect.

Interaction is an example that instantiates several such handlers and connects the corresponding callback using an access-to-subprogram parameter.