/* - Wed Oct 17 16:43:30 2001 by Malcy - started  */
/* Slightly modified to accept the entryname_v in ml_natdynload */
/* $Id: ndl.c,v 1.3 2005/09/18 21:58:00 oleg Exp $ */

#include <dlfcn.h>
#include <fail.h>
#include <misc.h>
#include <alloc.h>
#include <memory.h>
#include <custom.h>
#include <mlvalues.h>
#include <callback.h>

/* for debugging */
#include <stdio.h>
#if defined(DYN_DEBUG) && DYN_DEBUG
#define DBGPRINT fprintf
#else
#define DBGPRINT (void) 
#endif

/* in new roots.c */
extern long ** caml_dyn_frametable;
void init_frame_descriptors(void);

/* Operations on DYNlimits 
   This code is to operate on data/code limits in a dynamically
   loaded code.
   This code generalizes the simplistic handling of data/code
   limits in ../asmrun/startup.c
   We put the code here for convenience.
*/

struct DYNlimits caml_static_data_limits =
  {0,0,(struct DYNlimit *)0};
struct DYNlimits caml_code_area_limits = /* not dealt with yet */
  {0,0,(struct DYNlimit *)0};

/* Allocate that many entries, initially */
#define DYNlimits_init_alloc 10

static void debug_print_DYNlimits(const struct DYNlimits * dynlimits,
				  const char * title)
{
#if defined(DYN_DEBUG) && DYN_DEBUG
  const struct DYNlimit * const dl_end = dynlimits->limit + dynlimits->used;
  const struct DYNlimit * dl = dynlimits->limit;
  DBGPRINT (stderr,"\n%s: Dynlimits %p; size %d used %d limits %p\n",
	  title,dynlimits,dynlimits->size,dynlimits->used,dynlimits->limit);
  for(;dl != dl_end; dl++)
    DBGPRINT (stderr,"   [%p,%p]\n",dl->begin,dl->end);
#endif
}

/* check to see if the address is within limits */
int within_DYNlimitsP(const char * addr,
		      const struct DYNlimits * dynlimits)
{
  const struct DYNlimit * const dl_end = dynlimits->limit + dynlimits->used;
  const struct DYNlimit * dl = dynlimits->limit;
  debug_print_DYNlimits(dynlimits,"within_DYNlimitsP");
  DBGPRINT (stderr,"addr %p\n",addr);
  for(;dl != dl_end; dl++)
    if( addr >= dl->begin && addr < dl->end )
      return 1;
  DBGPRINT (stderr,"not found addr %p\n",addr);
  return 0;
}

static void add_to_dynlimits(struct DYNlimits * dynlimits,
		      const void * begin, const void * end)
{
  if( dynlimits->size == 0 )
  {				/* Initial allocation */
    dynlimits->limit = caml_stat_alloc(sizeof(struct DYNlimit) *
				       DYNlimits_init_alloc);
    dynlimits->used = 0;
    dynlimits->size = DYNlimits_init_alloc;
  }
  else if( dynlimits->size == dynlimits->used )
  {				/* Reallocate */
    const int new_size = 2 * dynlimits->size;
    dynlimits->limit = caml_stat_resize(dynlimits->limit,
					 sizeof(struct DYNlimit) *
					 new_size);
    dynlimits->size = new_size;
  }
  {
    struct DYNlimit * dl = dynlimits->limit + dynlimits->used;
    dynlimits->used++;
    dl->begin = begin;
    dl->end = end;
  }
  debug_print_DYNlimits(dynlimits,"add_to_dynlimits");
}



/*
 handle is the DL handle
 entryname is the name of the entry, a string like
 "camlTest_dyn1__entry"
 We locate in the shared object represented by [handle]
 the symbol whose name is [entryname] with "entry" suffix replaced by
 [new_suffix]
 */
static void * locate_suffixed_symbol(void * handle,
				     const char * entryname,
				     const char * new_suffix)
{
  const char entry_suffix [] = "entry";
  char new_name[256];
  char *p;
  if ( strlen(entryname) + strlen(new_suffix) >= sizeof(new_name)-2 )
      caml_fatal_error_arg("ndl.c: entryname `%s' is too long\n",entryname);
  strncpy(new_name,entryname,sizeof(new_name)-2);
  new_name[sizeof(new_name)-1] = '\0';
  p = new_name + strlen(new_name) - (sizeof(entry_suffix)-1);
  if( strcmp(p,entry_suffix) != 0 )
    caml_fatal_error_arg(
	    "ndl.c: wrong entryname `%s', should end in `entry'\n",
	    entryname);
  strcpy(p,new_suffix);

  return dlsym (handle, new_name);
}




static struct custom_operations dso_handle_ops = {
  "dsohandle",
  NULL,
  custom_compare_default,
  custom_hash_default,
  custom_serialize_default,
  custom_deserialize_default
};

value dso_handle_new (void *handle)
{
  value wrapper = alloc_custom (&dso_handle_ops, sizeof (void *), 0, 1);
  *((void **)Data_custom_val (wrapper)) = handle;
  return wrapper;
}

extern void shared_dyn_post_process (void);
static value * natdynlink_exn = NULL;

#define Link_error_Tag 0
#define Init_entry_not_found_Tag 1
#define Caml_entry_not_found_Tag 2
#define Fini_entry_not_found_Tag 3

#define Success_Tag 0
#define Entry_Exn_Tag 1

static void fail (const char *err, int tag) Noreturn;
static void fail (const char *err, int tag)
{
  value res = alloc_small (1, tag);
  Store_field (res, 0, copy_string (err));
  if (NULL == natdynlink_exn)
    natdynlink_exn = caml_named_value ("Natdynlink.Error");
  raise_with_arg (*natdynlink_exn, res);
}

static void * check_null(void * handle, void * addr)
{
  if (NULL == addr) {
    const char *err = dlerror ();
    dlclose (handle);
    fail (err, Caml_entry_not_found_Tag);
  }
  return addr;
}

value ml_natdynload (value private, value filename_v,
		     value entryname_v) /* ML */
{
  CAMLparam3 (private, filename_v, entryname_v);
  CAMLlocal3 (result, err, tup);

  value (*caml_shared_entry) (void);
  void (*caml_shared_fini) (void);
  void (*caml_shared_init) (void);
  void * frametable;

  char *filename  = String_val (filename_v);
  char *entryname = String_val (entryname_v);
  void *handle;

  handle = (private == Val_true)
    ? dlopen (filename, RTLD_NOW)
    : dlopen (filename, RTLD_NOW | RTLD_GLOBAL);

  if (NULL == handle)
    fail (dlerror (), Link_error_Tag);

  caml_shared_entry = check_null(handle, dlsym (handle, entryname));
  DBGPRINT (stderr,"\nentry name %s: %p\n",entryname,caml_shared_entry);

  frametable = check_null(handle,
		      locate_suffixed_symbol(handle,entryname,"frametable"));

  
  /* TODO: checks for duplicates: check frametable against existing
     entries in caml_dyn_frametable.
     This is not too critical though...
  */
  if( caml_dyn_frametable == NULL )
  {
    /* Allocate a new caml_dyn_frametable */
    caml_dyn_frametable = caml_stat_alloc(2 * sizeof(caml_dyn_frametable[0]));
    caml_dyn_frametable[0] = frametable;
    caml_dyn_frametable[1] = NULL;
  }
  else
  {
    /* reallocate the caml_dyn_frametable */
    int count = 0;
    for (count = 0; caml_dyn_frametable[count] != 0; count++)
      ;
    caml_dyn_frametable = caml_stat_resize(caml_dyn_frametable,
					   (count+1+1) * 
					    sizeof(caml_dyn_frametable[0]));
    caml_dyn_frametable[count] = frametable;
    caml_dyn_frametable[count+1] = NULL;
  }

  init_frame_descriptors();

  add_to_dynlimits(&caml_static_data_limits,
		   check_null(handle,
			      locate_suffixed_symbol(handle,entryname,
						     "data_begin")),
		   check_null(handle,
			      locate_suffixed_symbol(handle,entryname,
						     "data_end")));


#if 0
  caml_shared_fini = check_null(handle, dlsym (handle, "fini_shared"));

  caml_shared_init = check_null(handle, dlsym (handle, "init_shared"));

  caml_shared_init ();
  shared_dyn_post_process ();
#endif

  /* I cannot call  caml_shared_entry directly, as in 
      err = caml_shared_entry ();
     Becasue the shared entry is a CAML program and needs a properly
     set up frame. So, I need to invoke it as a call-back into OCaml
     from C.
     So, I need to use caml_callback_exn. However, the latter
     needs a closure as its first argument. But all I have is
     the code pointer. The examination of asmrun/i386.S shows however
     that a mere reference cell suffices. The second argument to
     caml_callback_exn is an argument to the closure. We use 0 --
     no argument is needed. That doesn't affect the stack,
     see again asmrun/i386.S
  */	
     
     
  err = caml_callback_exn((value)(&caml_shared_entry), 0);
  /* TODO: change the of natdynlink so I could return the value
     of the plusgin directly. It woulbe be unit anyway
     A better invocation: make a tail call to caml_shared_entry.
     In that case, there will be no need to mess with setting up
     a frame
  */	
  if (Is_exception_result (err)) {
    tup = alloc_tuple (2);
    Store_field (tup, 0, dso_handle_new (handle));
    Store_field (tup, 1, Extract_exception (err));
    result = alloc_small (1, Entry_Exn_Tag);
    Field (result, 0) = tup;
  } else {
    result = alloc_small (1, Success_Tag);
    Store_field (result, 0, err);
#if 0
    Store_field (result, 0, dso_handle_new (handle));
#endif
  }
  CAMLreturn (result);
}