Ajout de callback.[ch].

interp.c, mlvalues.h, signals.c: deplacement du code de callback dans
  callback.c
startup.c: debug de caml_startup


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

6 files changed, 18 insertions, 113 deletions

diff --git a/byterun/Makefile b/byterun/Makefile
index d62727e57..5f69ea498 100644
--- a/byterun/Makefile
+++ b/byterun/Makefile
@@ -9,13 +9,13 @@ OBJS=interp.o misc.o stacks.o fix_code.o startup.o main.o \
   fail.o signals.o printexc.o \
   compare.o ints.o floats.o str.o array.o io.o extern.o intern.o \
   hash.o sys.o meta.o parsing.o gc_ctrl.o terminfo.o md5.o obj.o \
-  lexing.o
+  lexing.o callback.o
 
 DOBJS=$(OBJS:.o=.d.o) instrtrace.d.o
 
 PRIMS=array.c compare.c extern.c floats.c gc_ctrl.c hash.c \
   intern.c interp.c ints.c io.c lexing.c md5.c meta.c obj.c parsing.c \
-  signals.c str.c sys.c terminfo.c
+  signals.c str.c sys.c terminfo.c callback.c
 
 all: ocamlrun
 
@@ -31,7 +31,7 @@ install:
 	ar rc $(LIBDIR)/libcamlrun.a $(OBJS)
 	cd $(LIBDIR); $(RANLIB) libcamlrun.a
 	if test -d $(LIBDIR)/caml; then : ; else mkdir $(LIBDIR)/caml; fi
-	cp mlvalues.h alloc.h misc.h $(LIBDIR)/caml
+	cp mlvalues.h alloc.h misc.h callback.h $(LIBDIR)/caml
 	sed -e '/#include ".*\/m.h/r ../config/m.h' \
             -e '/#include ".*\/s.h/r ../config/s.h' \
             -e '/#include "/d' config.h > $(LIBDIR)/caml/config.h
diff --git a/byterun/fix_code.c b/byterun/fix_code.c
index 54bc53771..363fbbb5a 100644
--- a/byterun/fix_code.c
+++ b/byterun/fix_code.c
@@ -43,19 +43,16 @@ void fixup_endianness(code, len)
 
 void ** instr_table;
 
-#if macintosh
-
 void thread_code (code_t code, asize_t len)
 {
   code_t p;
   int l [STOP + 1];
   int i;
   
-  for (i = 0; i <= STOP; i++){
+  for (i = 0; i <= STOP; i++) {
     l [i] = 0;
   }
-
-	/* Instructions with one operand */
+  /* Instructions with one operand */
   l[PUSHACC] = l[ACC] = l[POP] = l[ASSIGN] =
   l[PUSHENVACC] = l[ENVACC] = l[PUSH_RETADDR] = l[APPLY] =
   l[APPTERM1] = l[APPTERM2] = l[APPTERM3] = l[RETURN] =
@@ -66,69 +63,27 @@ void thread_code (code_t code, asize_t len)
   l[C_CALL1] = l[C_CALL2] = l[C_CALL3] = l[C_CALL4] = l[C_CALL5] =
   l[CONSTINT] = l[PUSHCONSTINT] = l[OFFSETINT] = l[OFFSETREF] = 1;
 
-	/* Instructions with two operands */
+  /* Instructions with two operands */
   l[APPTERM] = l[CLOSURE] = l[CLOSUREREC] = l[PUSHGETGLOBALFIELD] =
   l[GETGLOBALFIELD] = l[MAKEBLOCK] = l[C_CALLN] = 2;
 
   len /= sizeof(opcode_t);
   for (p = code; p < code + len; /*nothing*/) {
     opcode_t instr = *p;
-	if (instr < 0 || instr > STOP){
-	  fatal_error_arg ("Fatal error: bad opcode (%lx)\n", (void *) instr);
-	}
-    *p++ = (opcode_t)((unsigned long)(instr_table[instr]));
-	if (instr == SWITCH){
-	  uint32 sizes = *p++;
-	  uint32 const_size = sizes & 0xFFFF;
-	  uint32 block_size = sizes >> 16;
-	  p += const_size + block_size;
-	}else{
-	  p += l[instr];
+    if (instr < 0 || instr > STOP){
+      fatal_error_arg ("Fatal error: bad opcode (%lx)\n", (void *) instr);
     }
-  }
-  Assert(p == code + len);
-}
-
-#else
-
-void thread_code(code, len)
-     code_t code;
-     asize_t len;
-{
-  code_t p;
-  len /= sizeof(opcode_t);
-  for (p = code; p < code + len; /*nothing*/) {
-    opcode_t instr = *p;
-    Assert(instr >= 0 && instr <= STOP);
     *p++ = (opcode_t)((unsigned long)(instr_table[instr]));
-    switch(instr) {
-      /* Instructions with one operand */
-    case PUSHACC: case ACC: case POP: case ASSIGN:
-    case PUSHENVACC: case ENVACC: case PUSH_RETADDR: case APPLY:
-    case APPTERM1: case APPTERM2: case APPTERM3: case RETURN:
-    case GRAB: case PUSHGETGLOBAL: case GETGLOBAL: case SETGLOBAL:
-    case PUSHATOM: case ATOM: case MAKEBLOCK1: case MAKEBLOCK2:
-    case MAKEBLOCK3: case GETFIELD: case SETFIELD: case DUMMY:
-    case BRANCH: case BRANCHIF: case BRANCHIFNOT: case PUSHTRAP:
-    case C_CALL1: case C_CALL2: case C_CALL3: case C_CALL4: case C_CALL5:
-    case CONSTINT: case PUSHCONSTINT: case OFFSETINT: case OFFSETREF:
-      p += 1; break;
-      /* Instructions with two operands */
-    case APPTERM: case CLOSURE: case CLOSUREREC: case PUSHGETGLOBALFIELD:
-    case GETGLOBALFIELD: case MAKEBLOCK: case C_CALLN:
-      p += 2; break;
-      /* Instructions with N+1 operands */
-    case SWITCH:
-      { uint32 sizes = *p++;
-        uint32 const_size = sizes & 0xFFFF;
-        uint32 block_size = sizes >> 16;
-        p += const_size + block_size;
-        break; }
+    if (instr == SWITCH) {
+      uint32 sizes = *p++;
+      uint32 const_size = sizes & 0xFFFF;
+      uint32 block_size = sizes >> 16;
+      p += const_size + block_size;
+    } else {
+      p += l[instr];
     }
   }
   Assert(p == code + len);
 }
 
-#endif /* macintosh */
-
 #endif /* THREAD_CODE */
diff --git a/byterun/interp.c b/byterun/interp.c
index 94645b2fa..530a4dbc2 100644
--- a/byterun/interp.c
+++ b/byterun/interp.c
@@ -14,6 +14,7 @@
 /* The bytecode interpreter */
 
 #include "alloc.h"
+#include "callback.h"
 #include "fail.h"
 #include "fix_code.h"
 #include "instrtrace.h"
@@ -43,8 +44,6 @@ extern int volatile have_to_interact;
 
 sp is a local copy of the global variable extern_sp. */
 
-int callback_depth = 0;
-
 /* Instruction decoding */
 
 #ifdef THREADED_CODE
@@ -879,49 +878,3 @@ value interprete(prog, prog_size)
   }
 #endif
 }
-
-static opcode_t callback1_code[] = { ACC1, APPLY1, POP, 1, STOP };
-static opcode_t callback2_code[] = { ACC2, APPLY2, POP, 1, STOP };
-static opcode_t callback3_code[] = { ACC3, APPLY3, POP, 1, STOP };
-
-value callback(closure, arg)
-     value closure, arg;
-{
-  value res;
-  extern_sp -= 2;
-  extern_sp[0] = arg;
-  extern_sp[1] = closure;
-  callback_depth++;
-  res = interprete(callback1_code, sizeof(callback1_code));
-  callback_depth--;
-  return res;
-}
-
-value callback2(closure, arg1, arg2)
-     value closure, arg1, arg2;
-{
-  value res;
-  extern_sp -= 3;
-  extern_sp[0] = arg1;
-  extern_sp[1] = arg2;
-  extern_sp[2] = closure;
-  callback_depth++;
-  res = interprete(callback2_code, sizeof(callback2_code));
-  callback_depth--;
-  return res;
-}
-
-value callback3(closure, arg1, arg2, arg3)
-     value closure, arg1, arg2, arg3;
-{
-  value res;
-  extern_sp -= 4;
-  extern_sp[0] = arg1;
-  extern_sp[1] = arg2;
-  extern_sp[2] = arg3;
-  extern_sp[3] = closure;
-  callback_depth++;
-  res = interprete(callback3_code, sizeof(callback3_code));
-  callback_depth--;
-  return res;
-}
diff --git a/byterun/mlvalues.h b/byterun/mlvalues.h
index 96b632d3c..67a102e03 100644
--- a/byterun/mlvalues.h
+++ b/byterun/mlvalues.h
@@ -163,10 +163,6 @@ typedef opcode_t * code_t;
 #define Closure_tag 250
 #define Code_val(val) (((code_t *) (val)) [0])     /* Also an l-value. */
 
-value callback P((value closure, value arg));
-value callback2 P((value closure, value arg1, value arg2));
-value callback3 P((value closure, value arg1, value arg2, value arg3));
-
 /* If tag == Infix_tag : an infix header inside a closure */
 /* Infix_tag must be odd so that the infix header is scanned as an integer */
 
diff --git a/byterun/signals.c b/byterun/signals.c
index 8db4c4628..48684efa7 100644
--- a/byterun/signals.c
+++ b/byterun/signals.c
@@ -13,6 +13,7 @@
 
 #include <signal.h>
 #include "alloc.h"
+#include "callback.h"
 #include "config.h"
 #include "fail.h"
 #include "memory.h"
diff --git a/byterun/startup.c b/byterun/startup.c
index 6d66a0403..7d611d642 100644
--- a/byterun/startup.c
+++ b/byterun/startup.c
@@ -280,7 +280,7 @@ void caml_startup_code(code, code_size, data, argv)
     /* Load the code */
     start_code = code;
     /* Load the globals */
-    global_data = input_value_from_string((value)data, Val_int(0));
+    global_data = Field(input_value_from_string((value)data, Val_int(0)), 0);
     /* Ensure that the globals are in the major heap. */
     oldify(global_data, &global_data);
     /* Run the code */