starting to implement native dynlink for Unix

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@7864 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

asmcomp/asmlink.ml

@@ -211,8 +211,8 @@ let make_startup_file ppf filename units_list =
   compile_phrase
     (Cmmgen.globals_map
       (List.map
-        (fun (unit,_,_) ->
-          try (unit.ui_name, List.assoc unit.ui_name unit.ui_imports_cmi)
+        (fun (unit,_,crc) ->
+          try (unit.ui_name, List.assoc unit.ui_name unit.ui_imports_cmi, crc)
           with Not_found -> assert false)
         units_list));
   compile_phrase(Cmmgen.data_segment_table ("_startup" :: name_list));

asmcomp/cmmgen.mli

@@ -21,7 +21,7 @@ val send_function: int -> Cmm.phrase
 val curry_function: int -> Cmm.phrase list
 val entry_point: string list -> Cmm.phrase
 val global_table: string list -> Cmm.phrase
-val globals_map: (string * string) list -> Cmm.phrase
+val globals_map: (string * Digest.t * Digest.t) list -> Cmm.phrase
 val frame_table: string list -> Cmm.phrase
 val data_segment_table: string list -> Cmm.phrase
 val code_segment_table: string list -> Cmm.phrase

asmrun/Makefile

@@ -26,7 +26,7 @@ COBJS=startup.o main.o fail.o roots.o globroots.o signals.o \
   misc.o freelist.o major_gc.o minor_gc.o memory.o alloc.o compare.o ints.o \
   floats.o str.o array.o io.o extern.o intern.o hash.o sys.o parsing.o \
   gc_ctrl.o terminfo.o md5.o obj.o lexing.o printexc.o callback.o weak.o \
-  compact.o finalise.o custom.o unix.o backtrace.o
+  compact.o finalise.o custom.o unix.o backtrace.o natdynlink.o
 
 ASMOBJS=$(ARCH).o
 

asmrun/natdynlink.c

@@ -0,0 +1,55 @@
+#include "misc.h"
+#include "mlvalues.h"
+#include "memory.h"
+#include "stack.h"
+#include "callback.h"
+
+#include <dlfcn.h>
+#include <stdio.h>
+#include <string.h>
+
+void *getsym(void *handle, char *module, char *name){
+  char *fullname = malloc(strlen(module) + strlen(name) + 5);
+  sprintf(fullname, "caml%s%s", module, name);
+  void *sym = dlsym (handle, fullname);
+  if (NULL == sym) {
+    printf("natdynlink: cannot find symbol %s\n", fullname);
+    exit(2);
+  }
+  free(fullname);
+  return sym;
+}
+
+extern char caml_globals_map[];
+
+CAMLprim value caml_natdynlink_getmap(value unit)
+{
+  return (value)caml_globals_map;
+}
+
+
+CAMLprim value caml_natdynlink_open
+(value private, value filename, value symbol)
+{
+  CAMLparam3 (private, filename, symbol);
+  CAMLlocal3 (result, err, tup);
+
+  char *unit = String_val(symbol);
+
+  void *handle =
+    dlopen(String_val(filename),
+	   (private == Val_true
+	    ? RTLD_NOW
+	    : RTLD_NOW | RTLD_GLOBAL
+	    ));
+    
+  if (NULL == handle)
+    CAMLreturn(caml_copy_string(dlerror()));
+  
+  caml_register_frametable(getsym(handle,unit,"__frametable"));
+  caml_register_dyn_global((value)getsym(handle,unit,""));
+  void (*entrypoint)(void) = getsym(handle,unit,"__entry");
+  err = caml_callback((value)(&entrypoint), 0);
+
+  CAMLreturn (Val_unit);
+}

asmrun/roots.c

@@ -36,6 +36,37 @@ void (*caml_scan_roots_hook) (scanning_action) = NULL;
 frame_descr ** caml_frame_descriptors = NULL;
 int caml_frame_descriptors_mask;
 
+/* Linked-list of frametables */
+
+typedef struct link {
+  void *data;
+  struct link *next;
+} link;  
+
+link *cons(void *data, link *tl) {
+  link *lnk = caml_stat_alloc(sizeof(link));
+  lnk->data = data;
+  lnk->next = tl;
+  return lnk;
+}
+
+#define iter_list(list,lnk) \
+  for (lnk = list; lnk != NULL; lnk = lnk->next)
+    
+  
+
+link *frametables = NULL;
+
+void caml_register_frametable(intnat *table) {
+  frametables = cons(table,frametables);
+
+  if (NULL != caml_frame_descriptors) {
+    caml_stat_free(caml_frame_descriptors);
+    caml_frame_descriptors = NULL;
+    /* force caml_init_frame_descriptors to be called */
+  }
+}
+
 void caml_init_frame_descriptors(void)
 {
   intnat num_descr, tblsize, i, j, len;
@@ -43,11 +74,21 @@ void caml_init_frame_descriptors(void)
   frame_descr * d;
   uintnat nextd;
   uintnat h;
+  link *lnk;
 
+  static int inited = 0;
+  
+  if (!inited) {
+    for (i = 0; caml_frametable[i] != 0; i++)
+      caml_register_frametable(caml_frametable[i]);
+    inited = 1;
+  }
+  
   /* Count the frame descriptors */
   num_descr = 0;
-  for (i = 0; caml_frametable[i] != 0; i++)
-    num_descr += *(caml_frametable[i]);
+  iter_list(frametables,lnk) {
+    num_descr += *((intnat*) lnk->data);
+  }
 
   /* The size of the hashtable is a power of 2 greater or equal to
      2 times the number of descriptors */
@@ -61,21 +102,21 @@ void caml_init_frame_descriptors(void)
   caml_frame_descriptors_mask = tblsize - 1;
 
   /* Fill the hash table */
-  for (i = 0; caml_frametable[i] != 0; i++) {
-    tbl = caml_frametable[i];
+  iter_list(frametables,lnk) {
+    tbl = (intnat*) lnk->data;
     len = *tbl;
     d = (frame_descr *)(tbl + 1);
     for (j = 0; j < len; j++) {
       h = Hash_retaddr(d->retaddr);
       while (caml_frame_descriptors[h] != NULL) {
-        h = (h+1) & caml_frame_descriptors_mask;
+	h = (h+1) & caml_frame_descriptors_mask;
       }
       caml_frame_descriptors[h] = d;
       nextd =
-        ((uintnat)d +
-         sizeof(char *) + sizeof(short) + sizeof(short) +
-         sizeof(short) * d->num_live + sizeof(frame_descr *) - 1)
-        & -sizeof(frame_descr *);
+	((uintnat)d +
+	 sizeof(char *) + sizeof(short) + sizeof(short) +
+	 sizeof(short) * d->num_live + sizeof(frame_descr *) - 1)
+	& -sizeof(frame_descr *);
       if (d->frame_size & 1) nextd += 8;
       d = (frame_descr *) nextd;
     }
@@ -89,6 +130,11 @@ uintnat caml_last_return_address = 1; /* not in Caml code initially */
 value * caml_gc_regs;
 intnat caml_globals_inited = 0;
 static intnat caml_globals_scanned = 0;
+static link * caml_dyn_globals = NULL;
+
+void caml_register_dyn_global(value v) {
+  caml_dyn_globals = cons((void*) v,caml_dyn_globals);
+}
 
 /* Call [caml_oldify_one] on (at least) all the roots that point to the minor
    heap. */
@@ -105,6 +151,7 @@ void caml_oldify_local_roots (void)
   value * root;
   struct global_root * gr;
   struct caml__roots_block *lr;
+  link *lnk;
 
   /* The global roots */
   for (i = caml_globals_scanned;
@@ -117,6 +164,14 @@ void caml_oldify_local_roots (void)
   }
   caml_globals_scanned = caml_globals_inited;
 
+  /* Dynamic global roots */
+  iter_list(caml_dyn_globals, lnk) {
+    glob = (value) lnk->data;
+    for (j = 0; j < Wosize_val(glob); j++){
+      Oldify (&Field (glob, j));
+    }
+  }
+
   /* The stack and local roots */
   if (caml_frame_descriptors == NULL) caml_init_frame_descriptors();
   sp = caml_bottom_of_stack;
@@ -198,6 +253,7 @@ void caml_do_roots (scanning_action f)
   int i, j;
   value glob;
   struct global_root * gr;
+  link *lnk;
 
   /* The global roots */
   for (i = 0; caml_globals[i] != 0; i++) {
@@ -205,6 +261,15 @@ void caml_do_roots (scanning_action f)
     for (j = 0; j < Wosize_val(glob); j++)
       f (Field (glob, j), &Field (glob, j));
   }
+
+  /* Dynamic global roots */
+  iter_list(caml_dyn_globals, lnk) {
+    glob = (value) lnk->data;
+    for (j = 0; j < Wosize_val(glob); j++){
+      f (Field (glob, j), &Field (glob, j));
+    }
+  }
+
   /* The stack and local roots */
   if (caml_frame_descriptors == NULL) caml_init_frame_descriptors();
   caml_do_local_roots(f, caml_bottom_of_stack, caml_last_return_address,

asmrun/stack.h

@@ -114,6 +114,8 @@ extern int caml_frame_descriptors_mask;
   (((uintnat)(addr) >> 3) & caml_frame_descriptors_mask)
 
 extern void caml_init_frame_descriptors(void);
+extern void caml_register_frametable(intnat *);
+extern void caml_register_dyn_global(value);
 
 /* Declaration of variables used in the asm code */
 extern char * caml_bottom_of_stack;
@@ -124,5 +126,4 @@ extern value caml_globals[];
 extern intnat caml_globals_inited;
 extern intnat * caml_frametable[];
 
-
 #endif /* CAML_STACK_H */