/* $Id: mldl_prim.c,v 1.2 2005/03/26 21:23:56 pasalic Exp $
 *
 */

/* Interface to libdl.so */



#include <stdlib.h>
#include <string.h>
#include <stdio.h>
#ifdef DARWIN_VERSION_6

#elsif
#include <malloc.h> 
#endif

#include <ctype.h> 

#include "config.h"
#include "mlvalues.h"
#include "alloc.h"
#include "memory.h"
#include "fail.h"

#define HAVE_DLOPEN 1
#define HAVE_DLSYM 1
#define HAVE_DLERROR 1
#define HAVE_DLCLOSE 1

#define HAVE_DLFCN_H 1

#define HAVE_LIBDL 1


#ifdef HAVE_DLFCN_H
#include <dlfcn.h>
#else
/* refuse to work without prototypes */
#undef HAVE_DLOPEN
#undef HAVE_DLSYM
#undef HAVE_DLERROR
#undef HAVE_DLCLOSE
#endif

#undef ENABLE_DL
/* disable the libdl support if any of dlopen, dlsym, dlerror or dlclose
 * is missing.
 */
#ifdef HAVE_DLOPEN
#ifdef HAVE_DLSYM
#ifdef HAVE_DLERROR
#ifdef HAVE_DLCLOSE
#define ENABLE_DL
#endif
#endif
#endif
#endif


typedef struct library_s {
    char *name;
    void *handle;
} library;


static void finalize_library(value l)
{
    library *lib;

    lib = (library *) Field(l,1);
    if (lib == NULL) return;

    if (lib->name != NULL) {
      free(lib->name);
      lib->name = NULL;
    }


    /* Note: 
     * The library is NOT closed, because references to the library are not
     * under control of the garbage collector. "finalize_library" may be
     * called if the library is still being used.
     */
}


CAMLprim value dl_open (value name)
{
    library *lib;
    char *n;
    void *h;
    char *error;
    CAMLparam1(name);
    CAMLlocal1(l);

#ifndef ENABLE_DL
    caml_failwith("dl_open: not available on this platform");
#else

    n = String_val(name);
    h = dlopen(n, RTLD_NOW);
    error = dlerror();
    if (error != NULL) {
	caml_raise_sys_error(caml_copy_string(error));
    }
    
    lib = (library *) caml_stat_alloc(sizeof(library));
    lib->name = caml_stat_alloc(strlen(n)+1);
    strcpy(lib->name, n);
    lib->handle = h;
    l = caml_alloc_final(2, finalize_library, 1, 10000);
    Field(l,1) = (value) lib;

    CAMLreturn(l);
#endif
}


CAMLprim value dl_sym(value l, value name)
{
    library *lib;
    void *addr;
    char *error;
    CAMLparam2(l,name);
    CAMLlocal1(symbol);

#ifndef ENABLE_DL
    caml_failwith("dl_sym: not available on this platform");
#else

    lib = (library *) Field(l,1);

    if (lib->handle == NULL)
	caml_failwith("Dl: library no longer open");
    
    addr = dlsym(lib->handle, String_val(name));
    
    error = dlerror();
    if (error != NULL)
	caml_raise_sys_error(caml_copy_string(error));

    //symbol = caml_alloc(2,0);
    symbol = caml_alloc(2, Abstract_tag);
    Field(symbol,0) = (value) lib;
    Field(symbol,1) = (value) addr;

    CAMLreturn(symbol);
#endif
}


CAMLprim value dl_close(value l)
{
    library *lib;
    CAMLparam1(l);

#ifndef ENABLE_DL
    caml_failwith("dl_close: not available on this platform");
#else

    lib = (library *) Field(l,1);

    if (lib->handle == NULL)
	caml_failwith("Dl: library not open");

    dlclose(lib->handle);
    caml_stat_free(lib->name);

    lib->handle = NULL;
    lib->name = NULL;

    CAMLreturn(Val_unit);
#endif
}

/* Return an empty library value.  */
CAMLprim value dl_dummy_library (void)
{
    library *lib;
    CAMLparam0();
    CAMLlocal1(l);

    lib = (library *) caml_stat_alloc(sizeof(library));
    lib->name = NULL;
    lib->handle = NULL;
    l = caml_alloc_final(2, finalize_library, 1, 10000);
    Field(l,1) = (value) lib;

    CAMLreturn(l);
}

/* typedefs can be better read than type names: */
typedef value (*f1)(value);
typedef value (*f2)(value,value);
typedef value (*f3)(value,value,value);
typedef value (*f4)(value,value,value,value);
typedef value (*f5)(value,value,value,value,value);
typedef value (*f6)(value,value,value,value,value,value);
typedef value (*f7)(value,value,value,value,value,value,value);
typedef value (*f8)(value,value,value,value,value,value,value,value);
typedef value (*f9)(value,value,value,value,value,value,value,value,value);
typedef value (*f10)(value,value,value,value,value,value,value,value,value,value);

/* Note: In the following stubs, we do not need CAMLparamN because we do not
 * caml_allocate memory.
 */

CAMLprim value dl_call1(value s, value a1)
{
    library *lib;
    f1 addr;

    lib = (library *) Field(s,0);

    if (lib->handle == NULL)
	caml_failwith("Dl: library no longer open");

    addr = (f1) Field(s,1);

    return addr(a1);
}




CAMLprim value dl_call2(value s, value a1, value a2)
{
    library *lib;
    f2 addr;

    lib = (library *) Field(s,0);

    if (lib->handle == NULL)
	caml_failwith("Dl: library no longer open");

    addr = (f2) Field(s,1);

    return addr(a1,a2);
}


CAMLprim value dl_call3(value s, value a1, value a2, value a3)
{
    library *lib;
    f3 addr;

    lib = (library *) Field(s,0);

    if (lib->handle == NULL)
	caml_failwith("Dl: library no longer open");

    addr = (f3) Field(s,1);

    return addr(a1,a2,a3);
}


CAMLprim value dl_call4(value s, value a1, value a2, value a3, value a4)
{
    library *lib;
    f4 addr;

    lib = (library *) Field(s,0);

    if (lib->handle == NULL)
	caml_failwith("Dl: library no longer open");

    addr = (f4) Field(s,1);

    return addr(a1,a2,a3,a4);
}


CAMLprim value dl_call5(value s, value a1, value a2, value a3, value a4, value a5)
{
    library *lib;
    f5 addr;

    lib = (library *) Field(s,0);

    if (lib->handle == NULL)
	caml_failwith("Dl: library no longer open");

    addr = (f5) Field(s,1);

    return addr(a1,a2,a3,a4,a5);
}


CAMLprim value dl_call5_bytecode(value *argv, int argc)
{
    return dl_call5(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
}


CAMLprim value dl_call6(value s, value a1, value a2, value a3, value a4, value a5,
	       value a6)
{
    library *lib;
    f6 addr;

    lib = (library *) Field(s,0);

    if (lib->handle == NULL)
	caml_failwith("Dl: library no longer open");

    addr = (f6) Field(s,1);

    return addr(a1,a2,a3,a4,a5,a6);
}


CAMLprim value dl_call6_bytecode(value *argv, int argc)
{
    return dl_call6(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
		    argv[6]);
}


CAMLprim value dl_call7(value s, value a1, value a2, value a3, value a4, value a5,
	       value a6, value a7)
{
    library *lib;
    f7 addr;

    lib = (library *) Field(s,0);

    if (lib->handle == NULL)
	caml_failwith("Dl: library no longer open");

    addr = (f7) Field(s,1);

    return addr(a1,a2,a3,a4,a5,a6,a7);
}


CAMLprim value dl_call7_bytecode(value *argv, int argc)
{
    return dl_call7(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
		    argv[6], argv[7]);
}


CAMLprim value dl_call8(value s, value a1, value a2, value a3, value a4, value a5,
	       value a6, value a7, value a8)
{
    library *lib;
    f8 addr;

    lib = (library *) Field(s,0);

    if (lib->handle == NULL)
	caml_failwith("Dl: library no longer open");

    addr = (f8) Field(s,1);

    return addr(a1,a2,a3,a4,a5,a6,a7,a8);
}


CAMLprim value dl_call8_bytecode(value *argv, int argc)
{
    return dl_call8(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
		    argv[6], argv[7], argv[8]);
}


CAMLprim value dl_call9(value s, value a1, value a2, value a3, value a4, value a5,
	       value a6, value a7, value a8, value a9)
{
    library *lib;
    f9 addr;

    lib = (library *) Field(s,0);

    if (lib->handle == NULL)
	caml_failwith("Dl: library no longer open");

    addr = (f9) Field(s,1);

    return addr(a1,a2,a3,a4,a5,a6,a7,a8,a9);
}


CAMLprim value dl_call9_bytecode(value *argv, int argc)
{
    return dl_call9(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
		    argv[6], argv[7], argv[8], argv[9]);
}


CAMLprim value dl_call10(value s, value a1, value a2, value a3, value a4, value a5,
		value a6, value a7, value a8, value a9, value a10)
{
    library *lib;
    f10 addr;

    lib = (library *) Field(s,0);

    if (lib->handle == NULL)
	caml_failwith("Dl: library no longer open");

    addr = (f10) Field(s,1);

    return addr(a1,a2,a3,a4,a5,a6,a7,a8,a9,a10);
}


CAMLprim value dl_call10_bytecode(value *argv, int argc)
{
    return dl_call10(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
		     argv[6], argv[7], argv[8], argv[9], argv[10]);
}


CAMLprim value dl_call_all(value s, value a1)
{
    CAMLparam2(s,a1);
    library *lib;
    f1 addr;

    lib = (library *) Field(s,0);

    if (lib->handle == NULL)
	caml_failwith("Dl: library no longer open");

    addr = (f1) Field(s,1);
    //inspect_block(a1); 
    CAMLreturn(addr(a1));
}

value inspect (value v){  
  if (Is_long(v))   
    printf ("v is an integer (%ld) : %ld", (long) v, Long_val(v));  
  else if (Is_block(v))    
    printf ("v is a pointer");  
  else    
    printf ("v is neither an integer nor a pointer (?)");  
  printf("   ");  
  fflush(stdout) ;  
  return v ;
}

void margin (int n)  { 
  while (n-- > 0) printf(".");  
  return; 
}
void print_block (value v,int m) {  
  int size, i; 
  margin(m);  
  if (Is_long(v))     
    { 
      printf("immediate value (%lx)\n", Long_val(v));  
      return; 
    };  
  printf ("memory block: size=%d  -  ", size=Wosize_val(v));  
  switch (Tag_val(v))   {    
  case Closure_tag :         
    printf("closure with %d free variables\n", size-1);        
    margin(m+4); 
    printf("code pointer: %p\n",Code_val(v)) ;   
    for (i=1;i<size;i++)  
      print_block(Field(v,i), m+4);      
    break;    
  case String_tag :        
    printf("string: %s (%s)\n", String_val(v),(char *) v);        
    break;   
  case Double_tag:          
      printf("float: %g\n", Double_val(v));        
      break;    
  case Double_array_tag :        
      printf ("float array: ");        
      for (i=0;i<size/Double_wosize;i++)  
	printf("  %g", Double_field(v,i));        
      printf("\n");        
      break;    
  case Abstract_tag : 
    printf("abstract type\n"); 
    break;    
  default:         
    if (Tag_val(v)>=No_scan_tag) {
      printf("unknown tag"); 
      break; };         
    printf("structured block (tag=%d):\n",Tag_val(v));      
    for (i=0;i<size;i++) 
      print_block(Field(v,i),m+4);  
  }  
  return;
}

value inspect_block (value v)    { 
  print_block(v,4); 
  fflush(stdout); 
  return v;
}

/*-------------------------------------------------------------------------*/
/* F90 entry points and data. */ 

#ifdef IFC_70

/* Array descriptor for Intel F90 7.0.  */
typedef struct {
  long mark_offset;
  char *marked_base;
  char *base;
  long array_size;                        /* In elements.  */
  long element_size;                      /* In bytes.  */
  long element_size2;
  unsigned int rank: 8;
  unsigned int is_non_contig: 8;
  unsigned int zero: 8;
  unsigned int is_pointer: 8;
  long lb1;
  long ub1; 
  long ls1;                              /* Logical stride.  */
  long lb2;
  long ub2; 
  long ls2;                              /* Logical stride.  */
  long zero2;
} ifcdesc_t;

#else

/* Array descriptor for Intel F90 8.0.  */
typedef struct {
  char *base;
  long element_size;                     /* In bytes.  */
  long offset;                           /* Base+offset = start of array.  */
  /* The low-order bit set if the array has been defined.  Other bits
     are also used, such as indicating contiguous array.  */
  long flags;                            
  long rank; 
  long reserved;

  long extent1;                          /* In elements.  */
  long stride1;                          /* In bytes.  */
  long lb1; 
  long extent2;                          /* In elements.  */
  long stride2;                          /* In bytes.  */
  long lb2; 
} ifcdesc80_t;

#endif


CAMLprim value dl_f90call_i(value s, value a1)
{
    library *lib;
    typedef int (*fccty)(int *);
    fccty addr;

    lib = (library *) Field(s,0);

    if (lib->handle == NULL)
	caml_failwith("Dl: library no longer open");

    addr = (fccty) Field(s,1);
    { 
    int arg = Int_val(a1);   
    int tmp = addr(&arg);
    return Val_int((tmp));
    }
}

CAMLprim value dl_f90call_array_i(value s, value a1)
{
  
    library *lib;
    typedef int (*fccty)(long *);
    fccty addr;
    //long* addr1;
    int a;
    int size;
    int i;
    long* auto_i;

    lib = (library *) Field(s,0);
    if (lib->handle == NULL)
	caml_failwith("Dl: library no longer open");
    addr = (fccty) Field(s,1);
    
    //inspect_block(a1);  
    // get the size of the array
    size = Wosize_val(a1);
    //printf("Size is: %d\n", size);
    auto_i = (long*) malloc(sizeof(long) * size);

    // copy from Ocaml to C
    for (i = 0; i < size; i++) {
      auto_i[i] = Long_val(Field(a1,i));
    }
    
    // feed the C array into the F90 function.  This works for F90 since the
    // array is one dimensional.
    a = (addr(auto_i)); 
    //printf("Int back: %d\n", a);

    // copy back to OCaml array
    for (i = 0; i < size; i++) {
      caml_modify(&Field(a1,i),Val_long(auto_i[i]));
    }
    //inspect_block(a1);    
    
    free(auto_i);
   
    return Val_int(a);
}

CAMLprim value dl_f90call_array_f(value s, value a1)
{
    
    library *lib;
    typedef int (*fccty)(double *);
    fccty addr;
    //long* addr1;
    int a;
    int size;
    int i;
    double* auto_i;

    lib = (library *) Field(s,0);
    if (lib->handle == NULL)
	caml_failwith("Dl: library no longer open");
    addr = (fccty) Field(s,1);
    

    //inspect_block(a1);  
    // get the size of the array
    size = Wosize_val(a1);
    
    // floats occupy double space
    auto_i = (double*) malloc(sizeof(double) * size);

    // copy from Ocaml to C
    for (i = 0; i < (size / Double_wosize); i++) {
      auto_i[i] = Double_field(a1,i);
    }
    // feed the C array into the F90 function.  This works for F90 since the
    // array is one dimensional.
    a = (addr(auto_i)); 
    //printf("Int back: %d\n", a);

    // copy back to OCaml array
    for (i = 0; i < size; i++) {
      Store_double_field(a1,i,auto_i[i]);
    }
    //inspect_block(a1);    
    
    free(auto_i);
   
    return Val_int(a);
}

CAMLprim value dl_f90call_array_c_c(value s, value a1)
{
  library *lib;
  typedef int (*fccty)(char *);
  fccty addr;
  //long* addr1;
  int a, size_i, size_j, i, j, temp;
  char *fdata;
  value valtmp;
#ifdef IFC_70
  ifcdesc_t dopevec = { 0, 0, 0, 0, 1, 1, 0x02, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0 };
#else
  ifcdesc80_t dopevec = { 0, 1, 0, 0x0e000001, 2, 0, 0, 1, 0, 0, 0, 0 };
#endif

  lib = (library *) Field (s,0);
  if (lib->handle == NULL)
    caml_failwith ("Dl: library no longer open");

  addr = (fccty) Field (s, 1);
    
  // Get the size of the array.
  size_i = Wosize_val(a1);
  size_j = 0;
  temp = 0;

  // Determine second dimension.
  for (i = 0; i < size_i; i++) {
    temp = Wosize_val (Field (a1, i));
    if (size_j < temp) {
      size_j = temp;
    }
  }

  fdata = (char *) calloc ((size_i * size_j), sizeof (char));
 
  // Copy from Ocaml to F90's column-major layout.
  for (i = 0; i < size_i; i++) {
    valtmp = Field (a1, i);
    temp = Wosize_val (valtmp);
    for (j = 0; j < temp; j++) {
      fdata[j * size_i + i] = toascii (Long_val (Field (valtmp, j)));
    }
  }

  /* Setup the remaining dope vector fields.  */ 
#ifdef IFC_70
  dopevec.marked_base = dopevec.base = fdata; 
  dopevec.array_size = size_i * size_j;
  dopevec.ub1 = size_i - 1;
  dopevec.ub2 = size_j - 1;
  dopevec.ls2 = size_i;
#else
  dopevec.base = fdata; 
  dopevec.extent1 = size_i;
  dopevec.extent2 = size_j;
  dopevec.stride2 = size_i;
#endif

  // Invoke the F90 function.
  a = addr ((char *)&(dopevec.base)); 
  
  // Copy back to OCaml array
  for (i = 0; i < size_i; i++) {
    valtmp = Field(a1, i);
    temp = Wosize_val (valtmp);
    for (j = 0; j < temp; j++) {
      caml_modify(&(Field (valtmp, j)), Val_long (fdata[j * size_i + i]));
    }
  }
  free (fdata);

  return Val_int (a);
}

CAMLprim value dl_f90call_array_f_f(value s, value a1)
{
  library *lib;
  typedef int (*fccty)(double *);
  fccty addr;
  //long* addr1;
  int a, size_i, size_j, i, j, temp;
  double *fdata;
  value valtmp;
#ifdef IFC_70
  ifcdesc_t dopevec = { 0, 0, 0, 0, 8, 8, 0x02, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0 };
#else
  ifcdesc80_t dopevec = { 0, 8, 0, 0x0a000001, 2, 0, 0, 8, 0, 0, 0, 0 };
#endif

  lib = (library *) Field (s,0);
  if (lib->handle == NULL)
    caml_failwith ("Dl: library no longer open");

  addr = (fccty) Field (s, 1);
    
  // Get the size of the array.
  size_i = Wosize_val(a1);
  size_j = 0;
  temp = 0;

  // Determine second dimension.
  for (i = 0; i < size_i; i++) {
    temp = Wosize_val (Field (a1, i)) / Double_wosize;
    if (size_j < temp) {
      size_j = temp;
    }
  }

  fdata = (double *) calloc ((size_i * size_j), sizeof (double));
 
  // Copy from Ocaml to F90's column-major layout.
  for (i = 0; i < size_i; i++) {
    valtmp = Field (a1, i);
    temp = Wosize_val (valtmp) / Double_wosize;
    for (j = 0; j < temp; j++) {
      fdata[j * size_i + i] = Double_field (valtmp, j);
    }
  }

  /* Setup the remaining dope vector fields.  */ 
#ifdef IFC_70
  dopevec.marked_base = dopevec.base = (char *)fdata; 
  dopevec.array_size = size_i * size_j;
  dopevec.ub1 = size_i - 1;
  dopevec.ub2 = size_j - 1;
  dopevec.ls2 = size_i;
#else
  dopevec.base = (char *)fdata; 
  dopevec.extent1 = size_i;
  dopevec.extent2 = size_j;
  dopevec.stride2 = size_i * sizeof (double);
#endif

  // Invoke the F90 function.
  a = addr ((double *)&(dopevec.base)); 
  
  // Copy back to OCaml array
  for (i = 0; i < size_i; i++) {
    valtmp = Field(a1, i);
    temp = Wosize_val (valtmp) / Double_wosize;
    for (j = 0; j < temp; j++) {
      Store_double_field (valtmp, j, fdata[j * size_i + i]);
    }
  }
  free (fdata);

  return Val_int (a);
}

/* ======================================================================
 * 
 * $Log: mldl_prim.c,v $
 * Revision 1.2  2005/03/26 21:23:56  pasalic
 * mac os x compatibility
 *
 * Revision 1.1  2005/03/25 23:56:22  kswadi
 * Version merging Roumen's offshoring with Emir's tag elimination
 *
 * Revision 1.1.1.1  2005/03/17 20:21:08  roumen
 * merg
 *
 * Revision 1.18  2004/08/15 19:11:06  jle
 * bugfixes.
 *
 * Revision 1.17  2004/05/24 09:07:37  roumen
 * *** empty log message ***
 *
 * Revision 1.16  2004/05/11 04:43:40  roumen
 * unworking metaocaml version for oleg to play with:
 *
 * Revision 1.15  2004/04/27 17:23:25  roumen
 * C-subset typechecker complete; .!{C} construct complete
 *
 * Revision 1.14  2004/03/20 04:03:09  roumen
 * *** empty log message ***
 *
 * Revision 1.13  2004/03/19 23:16:45  jle
 * Add Intel IFC 8.0 dopevector support and array_f_f for F90.
 *
 * Revision 1.12  2004/03/06 23:09:59  jle
 * 2D array passing support for F90 translator (including Intel F90 array
 * descriptor support).
 *
 * Revision 1.11  2004/03/03 20:11:20  jle
 * Eliminate code duplication and various other clean-ups.
 *
 * Revision 1.10  2004/03/03 05:52:37  jle
 * F90 tweaks.
 *
 * Revision 1.9  2004/03/01 06:41:54  jle
 * Add dl_f90call_i.
 *
 * Revision 1.8  2004/02/14 19:51:23  roumen
 * *** empty log message ***
 *
 * Revision 1.7  2004/02/14 04:55:06  roumen
 * *** empty log message ***
 *
 * Revision 1.6  2004/02/13 03:19:25  roumen
 * *** empty log message ***
 *
 * Revision 1.5  2004/02/12 22:55:14  roumen
 * *** empty log message ***
 *
 * Revision 1.4  2004/02/06 22:28:19  roumen
 * *** empty log message ***
 *
 * Revision 1.3  2004/02/06 01:40:32  roumen
 * *** empty log message ***
 *
 * Revision 1.1  2004/02/06 01:36:02  roumen
 * *** empty log message ***
 *
 * Revision 1.4  2000/04/26 15:29:51  gerd
 * 	Upgrades for O'Caml 3.
 *
 * Revision 1.3  2000/02/20 01:54:29  gerd
 * 	Handled the case that dlopen etc are not present.
 *
 * Revision 1.1  1999/02/04 23:29:21  gerd
 * 	New dynamic linking facility.
 *
 *
 */