Call a function in a shared library/OCaml

From Rosetta Code

Here is the file "dlffi.ml" which provides the interface to OCaml:

<lang ocaml> type lib_handle type func_handle

type pointer

type arg_type = 

 | Int of int
 | Float of float
 | Double of float
 | String of string
 | Ptr of pointer
 | Void

type return_type = 

 | Return_int
 | Return_float
 | Return_double
 | Return_string
 | Return_ptr
 | Return_void

type rtld_flags = 

 | RTLD_LAZY
 | RTLD_NOW
 | RTLD_GLOBAL
 | RTLD_LOCAL
 | RTLD_NODELETE
 | RTLD_NOLOAD
 | RTLD_DEEPBIND

external dlopen: libname:string -> flags:rtld_flags list -> lib_handle = "ml_dlopen"

external dlsym: lib:lib_handle -> func_name:string -> func_handle = "ml_dlsym" external dlclose: lib:lib_handle -> unit = "ml_dlclose"

external fficall: func:func_handle -> args:arg_type array -> return:return_type -> arg_type = "ml_fficall" </lang>



Here is the file "dlffi_stubs.c":

<lang c>#include <dlfcn.h>

  1. include <ffi.h>
  1. include <caml/mlvalues.h>
  2. include <caml/memory.h>
  3. include <caml/alloc.h>
  4. include <caml/fail.h>
  1. include <stdio.h>
  2. include <stdlib.h>
  3. include <string.h>

static const int rtld_flags_table[] = { 

 RTLD_LAZY,
 RTLD_NOW,
 RTLD_GLOBAL,
 RTLD_LOCAL,
 RTLD_NODELETE,
 RTLD_NOLOAD,
 RTLD_DEEPBIND,

};

static inline int rtld_flags_val( value mask_list ) { 

 int c_mask = 0; 
 while (mask_list != Val_emptylist) {
   value head = Field(mask_list, 0);
   c_mask |= rtld_flags_table[Long_val(head)];
   mask_list = Field(mask_list, 1);
 }
 return c_mask;

}

CAMLprim value ml_dlopen( value libname, value ml_flags ) { 

 void *lib_handle = dlopen(String_val(libname), rtld_flags_val(ml_flags));
 if (lib_handle == NULL) failwith(dlerror());
 return (value) lib_handle;

}

CAMLprim value ml_dlsym( value lib_handle, value func_name ) { 

 char *status;
 void (*func_handle)();
 (void)dlerror();
 *(void **)(&func_handle) = dlsym((void *)lib_handle, String_val(func_name));
 status = dlerror();
 if (status != NULL) failwith(status);
 return (value) func_handle;

}

CAMLprim value ml_dlclose( value lib_handle ) { 

 int status = dlclose((void *)lib_handle);
 if (status != 0) failwith("dlclose");
 return Val_unit;

}

  1. define Val_tagged(v, tag) \
 this = caml_alloc(1, tag); \
 Store_field(this, 0, v);

//define ALLOC_INT_PARAM 1 //define ALLOC_DOUBLE_PARAM 1 //define ALLOC_STRING_PARAM 1

CAMLprim value ml_fficall( value func_handle, value ml_args, value ml_return ) { 

 CAMLparam3(func_handle, ml_args, ml_return);
 CAMLlocal2(ml_ret, this);

 unsigned int i, nargs;
 ffi_cif    cif;
 ffi_type   **arg_types;
 void       **arg_values;
 ffi_status status;
 ffi_type   *rtype;
 int ffi_prep_cif_failed = 0;

 nargs = Wosize_val(ml_args);

 arg_types  = (ffi_type **) malloc(nargs * sizeof(ffi_type *));
 arg_values = (void **) malloc(nargs * sizeof(void *));

 /* Set up the parameters */
 for (i = 0; i < nargs; i++) {
   value v = Field(ml_args, i);
   switch (Tag_val(v)) {
     case 0:  /* Int */
  1. if defined(ALLOC_INT_PARAM)
     { int *arg;
       arg = malloc(sizeof(int));
       *arg = Long_val(Field(v,0));
       arg_types[i] = &ffi_type_sint;
       arg_values[i] = arg;
     } break;
  1. else
     { arg_types[i] = &ffi_type_sint;
       Field(v,0) >>= 1;
       arg_values[i] = &Field(v,0);
     } break;
  1. endif
     case 1:  /* Float */
     { float *arg;
       arg = malloc(sizeof(float));
       *arg = (float) Double_val(Field(v,0));
       arg_types[i] = &ffi_type_float;
       arg_values[i] = arg;
     } break;
     case 2:  /* Double */
  1. if defined(ALLOC_DOUBLE_PARAM)
     { double *arg;
       arg = malloc(sizeof(double));
       *arg = Double_val(Field(v,0));
       arg_types[i] = &ffi_type_double;
       arg_values[i] = arg;
     } break;
  1. else
     { arg_types[i] = &ffi_type_double;
       arg_values[i] = &Double_val(Field(v,0));
     } break;
  1. endif
     case 3:  /* String */
  1. if defined(ALLOC_STRING_PARAM)
     { char *arg;
       int len = caml_string_length(Field(v,0)) + 1;
       arg = malloc(sizeof(char) * len);
       memcpy(arg, String_val(Field(v,0)), len);
       arg_types[i] = &ffi_type_float;
       arg_values[i] = &arg;
     } break;
  1. else
     { arg_types[i] = &ffi_type_pointer;
       arg_values[i] = &Byte(v,0);
     } break;
  1. endif
     case 4:  /* Ptr */
     { arg_types[i] = &ffi_type_pointer;
       arg_values[i] = &Field(v,0);
     } break;
     case 5:  /* Void */
       caml_invalid_argument("fficall");
       break;
   }
 }

 switch (Int_val(ml_return)) {  /* return_type */
   case 0:  /* Return_int */
     rtype = &ffi_type_sint;
     break;
   case 1:  /* Return_float */
     rtype = &ffi_type_float;
     break;
   case 2:  /* Return_double */
     rtype = &ffi_type_double;
     break;
   case 3:  /* Return_string */
     rtype = &ffi_type_pointer;
     break;
   case 4:  /* Return_ptr */
     rtype = &ffi_type_pointer;
     break;
   case 5:  /* Return_void */
     rtype = &ffi_type_uint;
     break;
 }

 status = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, rtype, arg_types);
 if (status != FFI_OK) {
   ffi_prep_cif_failed = 1;
   goto freeandfail;
 }

 switch (Int_val(ml_return)) {
   case 0:  /* Return_int */
   { int result;
     ffi_call(&cif, (void (*)(void)) func_handle, &result, arg_values);
     ml_ret = Val_tagged( Val_long(result), 0);
   } break;
   case 1:  /* Return_float */
   { float result;
     ffi_call(&cif, (void (*)(void)) func_handle, &result, arg_values);
     ml_ret = Val_tagged( caml_copy_double(result), 1);
   } break;
   case 2:  /* Return_double */
   { double result;
     ffi_call(&cif, (void (*)(void)) func_handle, &result, arg_values);
     ml_ret = Val_tagged( caml_copy_double(result), 2);
   } break;
   case 3:  /* Return_string */
   { char *result;
     ffi_call(&cif, (void (*)(void)) func_handle, &result, arg_values);
     ml_ret = Val_tagged( caml_copy_string((result == NULL ? "" : result)), 3);
   } break;
   case 4:  /* Return_ptr */
   { void *result;
     ffi_call(&cif, (void (*)(void)) func_handle, &result, arg_values);
     ml_ret = Val_tagged( (value) result, 4);
   } break;
   case 5:  /* Return_void */
   { ffi_arg result;
     ffi_call(&cif, (void (*)(void)) func_handle, &result, arg_values);
     ml_ret = Val_int(0);
   } break;
 }

freeandfail: 

 for (i = 0; i < nargs; i++) {
   switch (Tag_val(Field(ml_args, i))) {
     case 0:  /* Int */
  1. if defined(ALLOC_INT_PARAM)
       free(arg_values[i]);
  1. endif
       break;
     case 1:  /* Float */
       free(arg_values[i]);
       break;
     case 2:  /* Double */
  1. if defined(ALLOC_DOUBLE_PARAM)
       free(arg_values[i]);
  1. endif
       break;
     case 3:  /* String */
  1. if defined(ALLOC_STRING_PARAM)
     { char **arg;
       arg = arg_values[i];
       free(*arg);
     }
  1. endif
       break;
     case 4:  /* Ptr */
       break;
   }
 }
 free(arg_values);
 free(arg_types);

 if (ffi_prep_cif_failed)
   failwith("ffi_prep_cif");

 CAMLreturn(ml_ret);

} </lang>



Here is the "Makefile":

<lang make>FFI_LIBS := $(shell pkg-config --libs libffi) FFI_CFLAGS := $(shell pkg-config --cflags libffi)

all: test_opt

dlffi_stubs.o: dlffi_stubs.c ocamlc -g -c -ccopt $(FFI_CFLAGS) $<

dlldlffi_stubs.so: dlffi_stubs.o ocamlmklib -o dlffi_stubs $< -ldl $(FFI_LIBS)

dlffi.cmo: dlffi.ml ocamlc -c $<

dlffi.cmx: dlffi.ml ocamlopt -c $<

dlffi.cma: dlffi.cmo dlldlffi_stubs.so ocamlc -a -o $@ $< -dllib -ldlffi_stubs -cclib -ldl -cclib $(FFI_LIBS)

dlffi.cmxa: dlffi.cmx dlldlffi_stubs.so ocamlopt -a -o $@ $< -cclib -ldlffi_stubs -cclib -ldl -cclib $(FFI_LIBS)

fakelib.so: fakelib.c gcc -g -shared -nostartfiles $< -o $@

.PHONY: vim vim: vim dlffi_stubs.c dlffi.ml Makefile test.ml fakelib.c

test: dlffi.cma fakelib.so ocaml dlffi.cma test.ml

test.opt: test.ml dlffi.cmxa fakelib.so ocamlopt -g -o $@ -I . dlffi.cmxa $<

test_opt: test.opt ./$<

.PHONY: all clean test test_opt clean: rm -f *.[oa] *.so *.cm[ixoa] *.cmxa *.opt </lang> 

sed -i "s/        /\t/g" Makefile



Here is a test file named "test.ml":

<lang ocaml>open Dlffi

let handle_return = function 

 | Int v    -> Printf.printf "ocaml: got (Int %d)\n%!" v
 | Float v  -> Printf.printf "ocaml: got (Float %g)\n%!" v
 | Double v -> Printf.printf "ocaml: got (Double %g)\n%!" v
 | String v -> Printf.printf "ocaml: got (String \"%s\")\n%!" v
 | Ptr _    -> Printf.printf "ocaml: got (Ptr)\n%!"
 | Void     -> Printf.printf "ocaml: got (Void)\n%!"

let main1() = 

 let lib = dlopen "./fakelib.so" [RTLD_LAZY] in
 let func = dlsym ~lib ~func_name:"func_static_handle" in
 handle_return(fficall ~func ~args:[| Float 1.1 |] ~return:Return_int);
 handle_return(fficall ~func ~args:[| Float 2.2 |] ~return:Return_int);
 handle_return(fficall ~func ~args:[| Float 3.3 |] ~return:Return_int);
 dlclose ~lib;

let main2() = 

 let lib = dlopen "./fakelib.so" [RTLD_LAZY] in
 let func = dlsym ~lib ~func_name:"func_string_param" in
 handle_return(fficall ~func ~args:[| String "one" |] ~return:Return_string);
 dlclose ~lib;

let main3() = 

 let lib = dlopen "./fakelib.so" [RTLD_LAZY] in
 let func = dlsym ~lib ~func_name:"func_int_param" in
 handle_return(fficall ~func ~args:[| Int 244 |] ~return:Return_int);
 dlclose ~lib;

let main4() = 

 let lib = dlopen "./fakelib.so" [RTLD_LAZY] in
 let func = dlsym ~lib ~func_name:"func_double_param" in
 handle_return(fficall ~func ~args:[| Double 211.6 |] ~return:Return_double);
 dlclose ~lib;

let main5() = 

 let lib = dlopen "./fakelib.so" [RTLD_LAZY] in
 let func = dlsym ~lib ~func_name:"func_float_param" in
 handle_return(fficall ~func ~args:[| Float 211.7 |] ~return:Return_float);
 dlclose ~lib;

let main6() = 

 let lib = dlopen "./fakelib.so" [RTLD_LAZY] in
 let func = dlsym ~lib ~func_name:"func_void_param" in
 handle_return(fficall ~func ~args:[| |] ~return:Return_void);
 dlclose ~lib;

let () = 

 print_newline();  main1();
 print_newline();  main2();
 print_newline();  main3();
 print_newline();  main4();
 print_newline();  main5();
 print_newline();  main6();
</lang>



Here is a test library "fakelib.c":

<lang c>#include <stdio.h>

  1. include <stdlib.h>
  2. include <string.h>

int func_static_handle(float v) { 

 static int handle = 1;
 fprintf(stderr, "fun called %d times, arg: %g\n", handle, v);
 fflush(stderr);  /* ocaml's stderr is different from C's stderr */
 return handle++;

}

char *msgs[] = { 

 "alpha",
 "beta",
 "gamma",
 "delta",
 "epsilon",
 "zeta",

};

char *func_string_param(const char *s) { 

 static int handle = 0;
 char *ret;
 ret = &(msgs[handle % 6][0]);
 handle++;
 fprintf(stderr, "c: got string (%s) index[%d], returning: [%s]\n", s, handle, ret);
 fflush(stderr);
 return ret;
 //return NULL;  /* test the special case with NULL */

}

int func_int_param(const int d) { 

 printf("c: got int (%d)\n", d); fflush(stdout);
 return 107;

}

double func_double_param(const double d) { 

 printf("c: got double (%g)\n", d); fflush(stdout);
 return 233.1;

}

float func_float_param(const float f) { 

 printf("c: got float (%g)\n", f); fflush(stdout);
 return 233.2;

}

void func_void_param(void) { 

 printf("c: void function\n"); fflush(stdout);

} </lang>

If you find some use for this module, you can reuse this code under public domain.

Retrieved from "https://rosettacode.org/wiki/Call_a_function_in_a_shared_library/OCaml?oldid=149031"