value coq_offset_tcode(value code,value offset){
CAMLparam1(code);
CAMLlocal1(res);
res = caml_alloc_small(1, Abstract_tag);
Code_val(res) = Code_val(code) + Int_val(offset);
CAMLreturn(res);
}
void print_closure (value v, int pass, hash_table_t* ht)
{
int i,size;
size=Wosize_val(v);
if (pass == PASS2)
{
printf("< %p", Code_val(v));
if (size > 1)
{
printf(", ");
for (i=1; i<size; i++)
{
print_value(Field(v,i), pass, ht);
if (i < size-1)
printf(", ");
}
}
printf(" > ");
}
return;
}
value coq_tcode_of_code (value code) {
CAMLparam1 (code);
CAMLlocal1 (res);
code_t p, q;
asize_t len = (asize_t) caml_string_length(code);
res = caml_alloc_small(1, Abstract_tag);
q = coq_stat_alloc(len);
Code_val(res) = q;
len /= sizeof(opcode_t);
for (p = (code_t)code; p < (code_t)code + len; /*nothing*/) {
opcode_t instr;
COPY32(&instr,p);
p++;
if (instr < 0 || instr > STOP){
instr = STOP;
};
*q++ = VALINSTR(instr);
if (instr == SWITCH) {
uint32_t i, sizes, const_size, block_size;
COPY32(q,p); p++;
sizes=*q++;
const_size = sizes & 0xFFFFFF;
block_size = sizes >> 24;
sizes = const_size + block_size;
for(i=0; i<sizes; i++) { COPY32(q,p); p++; q++; };
} else if (instr == CLOSUREREC || instr==CLOSURECOFIX) {
void print_block(value v, int m)
{
int size, i;
margin(m);
if (Is_long(v))
{
printf("immediate value (%ld)\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;
case Custom_tag:
printf("abstract finalized 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 coq_kind_of_closure(value v) {
opcode_t * c;
int is_app = 0;
c = Code_val(v);
if (Is_instruction(c, GRAB)) return Val_int(0);
if (Is_instruction(c, RESTART)) {is_app = 1; c++;}
if (Is_instruction(c, GRABREC)) return Val_int(1+is_app);
if (Is_instruction(c, MAKEACCU)) return Val_int(3);
return Val_int(0);
}
value coq_makeaccu (value i) {
CAMLparam1(i);
CAMLlocal1(res);
code_t q = coq_stat_alloc(2 * sizeof(opcode_t));
res = caml_alloc_small(1, Abstract_tag);
Code_val(res) = q;
*q++ = VALINSTR(MAKEACCU);
*q = (opcode_t)Int_val(i);
CAMLreturn(res);
}
value coq_pushpop (value i) {
CAMLparam1(i);
CAMLlocal1(res);
code_t q;
res = caml_alloc_small(1, Abstract_tag);
int n = Int_val(i);
if (n == 0) {
q = coq_stat_alloc(sizeof(opcode_t));
Code_val(res) = q;
*q = VALINSTR(STOP);
CAMLreturn(res);
}
else {
q = coq_stat_alloc(3 * sizeof(opcode_t));
Code_val(res) = q;
*q++ = VALINSTR(POP);
*q++ = (opcode_t)n;
*q = VALINSTR(STOP);
CAMLreturn(res);
}
}
value coq_closure_arity(value clos) {
opcode_t * c = Code_val(clos);
if (Is_instruction(c,RESTART)) {
c++;
if (Is_instruction(c,GRAB)) return Val_int(3 + c[1] - Wosize_val(clos));
else {
if (Wosize_val(clos) != 2) failwith("Coq Values : coq_closure_arity");
return Val_int(1);
}
}
if (Is_instruction(c,GRAB)) return Val_int(1 + c[1]);
return Val_int(1);
}
CAMLprim value caml_reify_bytecode(value prog, value len)
{
value clos;
#ifdef ARCH_BIG_ENDIAN
caml_fixup_endianness((code_t) prog, (asize_t) Long_val(len));
#endif
#ifdef THREADED_CODE
caml_thread_code((code_t) prog, (asize_t) Long_val(len));
#endif
caml_prepare_bytecode((code_t) prog, (asize_t) Long_val(len));
clos = caml_alloc_small (1, Closure_tag);
Code_val(clos) = (code_t) prog;
return clos;
}
value coq_tcode_array(value tcodes) {
CAMLparam1(tcodes);
CAMLlocal2(res, tmp);
int i;
/* Assumes that the vector of types is small. This was implicit in the
previous code which was building the type array using Alloc_small. */
res = caml_alloc_small(Wosize_val(tcodes), Default_tag);
for (i = 0; i < Wosize_val(tcodes); i++) {
tmp = caml_alloc_small(1, Abstract_tag);
Code_val(tmp) = (code_t) Field(tcodes, i);
Store_field(res, i, tmp);
}
CAMLreturn(res);
}
void caml_debugger(enum event_kind event)
{
int frame_number;
value * frame;
intnat i, pos;
value val;
if (dbg_socket == -1) return; /* Not connected to a debugger. */
/* Reset current frame */
frame_number = 0;
frame = caml_extern_sp + 1;
/* Report the event to the debugger */
switch(event) {
case PROGRAM_START: /* Nothing to report */
goto command_loop;
case EVENT_COUNT:
putch(dbg_out, REP_EVENT);
break;
case BREAKPOINT:
putch(dbg_out, REP_BREAKPOINT);
break;
case PROGRAM_EXIT:
putch(dbg_out, REP_EXITED);
break;
case TRAP_BARRIER:
putch(dbg_out, REP_TRAP);
break;
case UNCAUGHT_EXC:
putch(dbg_out, REP_UNCAUGHT_EXC);
break;
}
caml_putword(dbg_out, caml_event_count);
if (event == EVENT_COUNT || event == BREAKPOINT) {
caml_putword(dbg_out, caml_stack_high - frame);
caml_putword(dbg_out, (Pc(frame) - caml_start_code) * sizeof(opcode_t));
} else {
/* No PC and no stack frame associated with other events */
caml_putword(dbg_out, 0);
caml_putword(dbg_out, 0);
}
caml_flush(dbg_out);
command_loop:
/* Read and execute the commands sent by the debugger */
while(1) {
switch(getch(dbg_in)) {
case REQ_SET_EVENT:
pos = caml_getword(dbg_in);
Assert (pos >= 0);
Assert (pos < caml_code_size);
caml_set_instruction(caml_start_code + pos / sizeof(opcode_t), EVENT);
break;
case REQ_SET_BREAKPOINT:
pos = caml_getword(dbg_in);
Assert (pos >= 0);
Assert (pos < caml_code_size);
caml_set_instruction(caml_start_code + pos / sizeof(opcode_t), BREAK);
break;
case REQ_RESET_INSTR:
pos = caml_getword(dbg_in);
Assert (pos >= 0);
Assert (pos < caml_code_size);
pos = pos / sizeof(opcode_t);
caml_set_instruction(caml_start_code + pos, caml_saved_code[pos]);
break;
case REQ_CHECKPOINT:
#ifndef _WIN32
i = fork();
if (i == 0) {
close_connection(); /* Close parent connection. */
open_connection(); /* Open new connection with debugger */
} else {
caml_putword(dbg_out, i);
caml_flush(dbg_out);
}
#else
caml_fatal_error("error: REQ_CHECKPOINT command");
exit(-1);
#endif
break;
case REQ_GO:
caml_event_count = caml_getword(dbg_in);
return;
case REQ_STOP:
exit(0);
break;
case REQ_WAIT:
#ifndef _WIN32
wait(NULL);
#else
caml_fatal_error("Fatal error: REQ_WAIT command");
exit(-1);
#endif
break;
case REQ_INITIAL_FRAME:
frame = caml_extern_sp + 1;
/* Fall through */
case REQ_GET_FRAME:
caml_putword(dbg_out, caml_stack_high - frame);
if (frame < caml_stack_high){
caml_putword(dbg_out, (Pc(frame) - caml_start_code) * sizeof(opcode_t));
}else{
caml_putword (dbg_out, 0);
}
caml_flush(dbg_out);
break;
case REQ_SET_FRAME:
i = caml_getword(dbg_in);
frame = caml_stack_high - i;
break;
case REQ_UP_FRAME:
i = caml_getword(dbg_in);
if (frame + Extra_args(frame) + i + 3 >= caml_stack_high) {
caml_putword(dbg_out, -1);
} else {
frame += Extra_args(frame) + i + 3;
caml_putword(dbg_out, caml_stack_high - frame);
caml_putword(dbg_out, (Pc(frame) - caml_start_code) * sizeof(opcode_t));
}
caml_flush(dbg_out);
break;
case REQ_SET_TRAP_BARRIER:
i = caml_getword(dbg_in);
caml_trap_barrier = caml_stack_high - i;
break;
case REQ_GET_LOCAL:
i = caml_getword(dbg_in);
putval(dbg_out, Locals(frame)[i]);
caml_flush(dbg_out);
break;
case REQ_GET_ENVIRONMENT:
i = caml_getword(dbg_in);
putval(dbg_out, Field(Env(frame), i));
caml_flush(dbg_out);
break;
case REQ_GET_GLOBAL:
i = caml_getword(dbg_in);
putval(dbg_out, Field(caml_global_data, i));
caml_flush(dbg_out);
break;
case REQ_GET_ACCU:
putval(dbg_out, *caml_extern_sp);
caml_flush(dbg_out);
break;
case REQ_GET_HEADER:
val = getval(dbg_in);
caml_putword(dbg_out, Hd_val(val));
caml_flush(dbg_out);
break;
case REQ_GET_FIELD:
val = getval(dbg_in);
i = caml_getword(dbg_in);
if (Tag_val(val) != Double_array_tag) {
putch(dbg_out, 0);
putval(dbg_out, Field(val, i));
} else {
double d = Double_field(val, i);
putch(dbg_out, 1);
caml_really_putblock(dbg_out, (char *) &d, 8);
}
caml_flush(dbg_out);
break;
case REQ_MARSHAL_OBJ:
val = getval(dbg_in);
safe_output_value(dbg_out, val);
caml_flush(dbg_out);
break;
case REQ_GET_CLOSURE_CODE:
val = getval(dbg_in);
caml_putword(dbg_out, (Code_val(val)-caml_start_code) * sizeof(opcode_t));
caml_flush(dbg_out);
break;
case REQ_SET_FORK_MODE:
caml_debugger_fork_mode = caml_getword(dbg_in);
break;
}
}
}
value coq_int_tcode(value pc, value offset) {
code_t code = Code_val(pc);
return Val_int(*((code_t) code + Int_val(offset)));
}
value coq_set_bytecode_field(value v, value i, value code) {
// No write barrier because the bytecode does not live on the OCaml heap
Field(v, Long_val(i)) = (value) Code_val(code);
return Val_unit;
}
value coq_is_accumulate_code(value code){
code_t q = Code_val(code);
int res;
res = Is_instruction(q,ACCUMULATE);
return Val_bool(res);
}