Browse files

Merge branch 'ocamlclean'

Conflicts:
	NOTES.md
  • Loading branch information...
2 parents f6c756c + 527bc83 commit 82b1692990e4072faa9a54edb53e8ede49fdda87 @avsm committed Apr 23, 2012
View
18 NOTES.md
@@ -46,3 +46,21 @@ You can also define a suite of tests and run them all:
# run a suite of tests, as listed in .suite
$ mir-build lwt.run
$ cat _build/lwt.run
+
+## Bytecode targets
+
+For the UNIX targets, there are 3 targets (by the filename extension):
+
+* `.bin`: native code
+* `.bcbin`: bytecode as an embedded callback
+* `.bcxbin`: bytecode with deadcode-elimination via ocamlclean [1]
+
+For Xen, there is a bytecode (that requires ocamlclean) and native code:
+
+* `.xen`: native code microkernel
+* `.bcxen`: bytecode microkernel with deadcode-elimination via ocamlclean [1]
+
+Note that ocamlclean can be quite slow (minutes) for larger applications,
+hence it isnt done by default for the bytecode target.
+
+[1] Modified to support Mirage, at http://github.com/avsm/ocamlclean
View
6 assemble.sh
@@ -23,11 +23,11 @@ function assemble_xen {
echo Assembling: Xen
OBJ=${BUILDDIR}/xen
mkdir -p ${OBJ}/lib ${OBJ}/syntax
- for i in dietlibc/libdiet.a libm/libm.a ocaml/libocaml.a kernel/libxen.a kernel/libxencaml.a kernel/x86_64.o; do
+ for i in dietlibc/libdiet.a libm/libm.a ocaml/libocaml.a ocaml/libocamlbc.a kernel/libxen.a kernel/libxencaml.a kernel/longjmp.o kernel/x86_64.o; do
cp ${ROOT}/lib/_build/xen/os/runtime_xen/$i ${OBJ}/lib/
done
cp ${ROOT}/lib/os/runtime_xen/kernel/mirage-x86_64.lds ${OBJ}/lib/
- cp ${ROOT}/lib/_build/xen/std/*.{cmi,cmx,a,o,cmxa} ${OBJ}/lib/
+ cp ${ROOT}/lib/_build/xen/std/*.{cmi,cmo,cma,cmx,a,o,cmxa} ${OBJ}/lib/
else
echo Skipping: Xen
fi
@@ -45,7 +45,7 @@ function assemble_unix {
for i in libunixrun.a main.o; do
cp ${ROOT}/lib/_build/unix-$1/os/runtime_unix/$i ${OBJ}/lib/
done
- cp ${ROOT}/lib/_build/unix-$1/std/*.{cmi,cmx,cmxa,a,o,cmo} ${OBJ}/lib/
+ cp ${ROOT}/lib/_build/unix-$1/std/*.{cmi,cma,cmx,cmxa,a,o,cmo} ${OBJ}/lib/
}
function assemble_node {
View
15 lib/myocamlbuild.ml
@@ -147,9 +147,12 @@ module CC = struct
(* defines used by the ocaml runtime, as well as includes *)
let ocaml_debug_inc = if debug then [A "-DDEBUG"] else []
let ocaml_incs = [
- A "-DCAML_NAME_SPACE"; A "-DNATIVE_CODE"; A "-DTARGET_amd64"; A "-DSYS_xen";
+ A "-DCAML_NAME_SPACE"; A "-DTARGET_amd64"; A "-DSYS_xen";
A (ps "-I%s/os/runtime_xen/ocaml" Pathname.pwd) ] @ ocaml_debug_inc
+ let ocaml_asmrun = [ A"-DNATIVE_CODE" ]
+ let ocaml_byterun = [ ]
+
(* ocaml system include directory i.e. /usr/lib/ocaml *)
let ocaml_sys_incs = [ A"-I"; Px (Util.run_and_read "ocamlc -where"); ]
@@ -180,6 +183,14 @@ module CC = struct
Cmd(S[A ar; A"rc"; Px a; T(tags_of_pathname a++"c"++"archive"); atomize objs])
let () =
+ rule "cc: .nc.c -> .c"
+ ~prod:"%.nc.c" ~dep:"%.c"
+ (fun env _ -> cp (env "%.c") (env "%.nc.c"));
+
+ rule "cc: .bc.c -> .c"
+ ~prod:"%.bc.c" ~dep:"%.c"
+ (fun env _ -> cp (env "%.c") (env "%.bc.c"));
+
rule "cc: .c -> .o include ocaml dir"
~tags:["cc"; "c"]
~prod:"%.o" ~dep:"%.c"
@@ -312,6 +323,8 @@ let _ = dispatch begin function
flag ["c"; "compile"; "include_xen"] & S CC.xen_incs;
flag ["c"; "compile"; "include_libm"] & S CC.libm_incs;
flag ["c"; "compile"; "include_ocaml"] & S CC.ocaml_incs;
+ flag ["c"; "compile"; "ocaml_byterun"] & S CC.ocaml_byterun;
+ flag ["c"; "compile"; "ocaml_asmrun"] & S CC.ocaml_asmrun;
flag ["c"; "compile"; "include_system_ocaml"] & S CC.ocaml_sys_incs;
flag ["c"; "compile"; "include_dietlibc"] & S CC.dietlibc_incs;
flag ["c"; "compile"; "pic"] & S [A"-fPIC"]
View
2 lib/os/runtime_xen/all.itarget
@@ -3,4 +3,6 @@ libm/libm.a
kernel/libxen.a
kernel/libxencaml.a
ocaml/libocaml.a
+ocaml/libocamlbc.a
+kernel/longjmp.o
kernel/x86_64.o
View
23 lib/os/runtime_xen/kernel/longjmp.S
@@ -0,0 +1,23 @@
+#include <setjmp.h>
+
+.text
+.global __longjmp
+.type __longjmp,@function
+__longjmp:
+ mov $1,%eax
+ /* Restore the return address now. */
+ movq (JB_PC*8)(%rdi),%rdx
+ /* Restore registers. */
+ movq (JB_RBX*8)(%rdi),%rbx
+ movq (JB_RBP*8)(%rdi),%rbp
+ movq (JB_R12*8)(%rdi),%r12
+ movq (JB_R13*8)(%rdi),%r13
+ movq (JB_R14*8)(%rdi),%r14
+ movq (JB_R15*8)(%rdi),%r15
+ movq (JB_RSP*8)(%rdi),%rsp
+ /* never return 0 */
+ test %esi,%esi
+ cmovne %esi,%eax
+ /* Jump to saved PC. */
+ jmp *%rdx
+.size __longjmp,.-__longjmp;
View
3 lib/os/runtime_xen/ocaml/_tags
@@ -1 +1,4 @@
<*.c> or <*.S>: include_xen,include_ocaml
+<*.S>: ocaml_asmrun
+<*.bc.c>: ocaml_byterun
+<*.nc.c>: ocaml_asmrun
View
315 lib/os/runtime_xen/ocaml/backtrace_bc.c
@@ -0,0 +1,315 @@
+/***********************************************************************/
+/* */
+/* Objective Caml */
+/* */
+/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
+/* */
+/* Copyright 2000 Institut National de Recherche en Informatique et */
+/* en Automatique. All rights reserved. This file is distributed */
+/* under the terms of the GNU Library General Public License, with */
+/* the special exception on linking described in file ../LICENSE. */
+/* */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Stack backtrace for uncaught exceptions */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <fcntl.h>
+#include "config.h"
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+#include "mlvalues.h"
+#include "alloc.h"
+#include "io.h"
+#include "instruct.h"
+#include "intext.h"
+#include "exec.h"
+#include "fix_code.h"
+#include "memory.h"
+#include "startup.h"
+#include "stacks.h"
+#include "sys.h"
+#include "backtrace.h"
+
+CAMLexport int caml_backtrace_active = 0;
+CAMLexport int caml_backtrace_pos = 0;
+CAMLexport code_t * caml_backtrace_buffer = NULL;
+CAMLexport value caml_backtrace_last_exn = Val_unit;
+CAMLexport char * caml_cds_file = NULL;
+#define BACKTRACE_BUFFER_SIZE 1024
+
+/* Location of fields in the Instruct.debug_event record */
+enum { EV_POS = 0,
+ EV_MODULE = 1,
+ EV_LOC = 2,
+ EV_KIND = 3 };
+
+/* Location of fields in the Location.t record. */
+enum { LOC_START = 0,
+ LOC_END = 1,
+ LOC_GHOST = 2 };
+
+/* Location of fields in the Lexing.position record. */
+enum {
+ POS_FNAME = 0,
+ POS_LNUM = 1,
+ POS_BOL = 2,
+ POS_CNUM = 3
+};
+
+/* Start or stop the backtrace machinery */
+
+CAMLprim value caml_record_backtrace(value vflag)
+{
+ int flag = Int_val(vflag);
+
+ if (flag != caml_backtrace_active) {
+ caml_backtrace_active = flag;
+ caml_backtrace_pos = 0;
+ if (flag) {
+ caml_register_global_root(&caml_backtrace_last_exn);
+ } else {
+ caml_remove_global_root(&caml_backtrace_last_exn);
+ }
+ /* Note: lazy initialization of caml_backtrace_buffer in
+ caml_stash_backtrace to simplify the interface with the thread
+ libraries */
+ }
+ return Val_unit;
+}
+
+/* Return the status of the backtrace machinery */
+
+CAMLprim value caml_backtrace_status(value vunit)
+{
+ return Val_bool(caml_backtrace_active);
+}
+
+/* Store the return addresses contained in the given stack fragment
+ into the backtrace array */
+
+void caml_stash_backtrace(value exn, code_t pc, value * sp)
+{
+ code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size);
+ if (pc != NULL) pc = pc - 1;
+ if (exn != caml_backtrace_last_exn) {
+ caml_backtrace_pos = 0;
+ caml_backtrace_last_exn = exn;
+ }
+ if (caml_backtrace_buffer == NULL) {
+ caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
+ if (caml_backtrace_buffer == NULL) return;
+ }
+ if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
+ if (pc >= caml_start_code && pc < end_code){
+ caml_backtrace_buffer[caml_backtrace_pos++] = pc;
+ }
+ for (/*nothing*/; sp < caml_trapsp; sp++) {
+ code_t p = (code_t) *sp;
+ if (p >= caml_start_code && p < end_code) {
+ if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) break;
+ caml_backtrace_buffer[caml_backtrace_pos++] = p;
+ }
+ }
+}
+
+/* Read the debugging info contained in the current bytecode executable.
+ Return a Caml array of Caml lists of debug_event records in "events",
+ or Val_false on failure. */
+
+#ifndef O_BINARY
+#define O_BINARY 0
+#endif
+
+#ifdef SYS_xen
+static value read_debug_info(void) { return Val_false; }
+#else
+static value read_debug_info(void)
+{
+ CAMLparam0();
+ CAMLlocal1(events);
+ char * exec_name;
+ int fd;
+ struct exec_trailer trail;
+ struct channel * chan;
+ uint32 num_events, orig, i;
+ value evl, l;
+
+ if (caml_cds_file != NULL) {
+ exec_name = caml_cds_file;
+ } else {
+ exec_name = caml_exe_name;
+ }
+ fd = caml_attempt_open(&exec_name, &trail, 1);
+ if (fd < 0) CAMLreturn(Val_false);
+ caml_read_section_descriptors(fd, &trail);
+ if (caml_seek_optional_section(fd, &trail, "DBUG") == -1) {
+ close(fd);
+ CAMLreturn(Val_false);
+ }
+ chan = caml_open_descriptor_in(fd);
+ num_events = caml_getword(chan);
+ events = caml_alloc(num_events, 0);
+ for (i = 0; i < num_events; i++) {
+ orig = caml_getword(chan);
+ evl = caml_input_val(chan);
+ /* Relocate events in event list */
+ for (l = evl; l != Val_int(0); l = Field(l, 1)) {
+ value ev = Field(l, 0);
+ Field(ev, EV_POS) = Val_long(Long_val(Field(ev, EV_POS)) + orig);
+ }
+ /* Record event list */
+ Store_field(events, i, evl);
+ }
+ caml_close_channel(chan);
+ CAMLreturn(events);
+}
+#endif
+
+/* Search the event for the given PC. Return Val_false if not found. */
+
+static value event_for_location(value events, code_t pc)
+{
+ mlsize_t i;
+ value pos, l, ev, ev_pos, best_ev;
+
+ best_ev = 0;
+ Assert(pc >= caml_start_code && pc < caml_start_code + caml_code_size);
+ pos = Val_long((char *) pc - (char *) caml_start_code);
+ for (i = 0; i < Wosize_val(events); i++) {
+ for (l = Field(events, i); l != Val_int(0); l = Field(l, 1)) {
+ ev = Field(l, 0);
+ ev_pos = Field(ev, EV_POS);
+ if (ev_pos == pos) return ev;
+ /* ocamlc sometimes moves an event past a following PUSH instruction;
+ allow mismatch by 1 instruction. */
+ if (ev_pos == pos + 8) best_ev = ev;
+ }
+ }
+ if (best_ev != 0) return best_ev;
+ return Val_false;
+}
+
+/* Extract location information for the given PC */
+
+struct loc_info {
+ int loc_valid;
+ int loc_is_raise;
+ char * loc_filename;
+ int loc_lnum;
+ int loc_startchr;
+ int loc_endchr;
+};
+
+static void extract_location_info(value events, code_t pc,
+ /*out*/ struct loc_info * li)
+{
+ value ev, ev_start;
+
+ ev = event_for_location(events, pc);
+ li->loc_is_raise = caml_is_instruction(*pc, RAISE);
+ if (ev == Val_false) {
+ li->loc_valid = 0;
+ return;
+ }
+ li->loc_valid = 1;
+ ev_start = Field (Field (ev, EV_LOC), LOC_START);
+ li->loc_filename = String_val (Field (ev_start, POS_FNAME));
+ li->loc_lnum = Int_val (Field (ev_start, POS_LNUM));
+ li->loc_startchr =
+ Int_val (Field (ev_start, POS_CNUM))
+ - Int_val (Field (ev_start, POS_BOL));
+ li->loc_endchr =
+ Int_val (Field (Field (Field (ev, EV_LOC), LOC_END), POS_CNUM))
+ - Int_val (Field (ev_start, POS_BOL));
+}
+
+/* Print location information */
+
+static void print_location(struct loc_info * li, int index)
+{
+ char * info;
+
+ /* Ignore compiler-inserted raise */
+ if (!li->loc_valid && li->loc_is_raise) return;
+
+ if (li->loc_is_raise) {
+ /* Initial raise if index == 0, re-raise otherwise */
+ if (index == 0)
+ info = "Raised at";
+ else
+ info = "Re-raised at";
+ } else {
+ if (index == 0)
+ info = "Raised by primitive operation at";
+ else
+ info = "Called from";
+ }
+ if (! li->loc_valid) {
+ fprintf(stderr, "%s unknown location\n", info);
+ } else {
+ fprintf (stderr, "%s file \"%s\", line %d, characters %d-%d\n",
+ info, li->loc_filename, li->loc_lnum,
+ li->loc_startchr, li->loc_endchr);
+ }
+}
+
+/* Print a backtrace */
+
+CAMLexport void caml_print_exception_backtrace(void)
+{
+ value events;
+ int i;
+ struct loc_info li;
+
+ events = read_debug_info();
+
+ if (events == Val_false) {
+ fprintf(stderr,
+ "(Program not linked with -g, cannot print stack backtrace)\n");
+ return;
+ }
+ for (i = 0; i < caml_backtrace_pos; i++) {
+ extract_location_info(events, caml_backtrace_buffer[i], &li);
+ print_location(&li, i);
+ }
+}
+
+/* Convert the backtrace to a data structure usable from Caml */
+
+CAMLprim value caml_get_exception_backtrace(value unit)
+{
+ CAMLparam0();
+ CAMLlocal5(events, res, arr, p, fname);
+ int i;
+ struct loc_info li;
+
+ events = read_debug_info();
+ if (events == Val_false) {
+ res = Val_int(0); /* None */
+ } else {
+ arr = caml_alloc(caml_backtrace_pos, 0);
+ for (i = 0; i < caml_backtrace_pos; i++) {
+ extract_location_info(events, caml_backtrace_buffer[i], &li);
+ if (li.loc_valid) {
+ fname = caml_copy_string(li.loc_filename);
+ p = caml_alloc_small(5, 0);
+ Field(p, 0) = Val_bool(li.loc_is_raise);
+ Field(p, 1) = fname;
+ Field(p, 2) = Val_int(li.loc_lnum);
+ Field(p, 3) = Val_int(li.loc_startchr);
+ Field(p, 4) = Val_int(li.loc_endchr);
+ } else {
+ p = caml_alloc_small(1, 1);
+ Field(p, 0) = Val_bool(li.loc_is_raise);
+ }
+ caml_modify(&Field(arr, i), p);
+ }
+ res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */
+ }
+ CAMLreturn(res);
+}
View
8 lib/os/runtime_xen/ocaml/dynlink.c
@@ -60,10 +60,12 @@ static c_primitive lookup_primitive(char * name)
if (strcmp(name, caml_names_of_builtin_cprim[i]) == 0)
return caml_builtin_cprim[i];
}
+#ifndef SYS_xen
for (i = 0; i < shared_libs.size; i++) {
res = caml_dlsym(shared_libs.contents[i], name);
if (res != NULL) return (c_primitive) res;
}
+#endif
return NULL;
}
@@ -72,6 +74,7 @@ static c_primitive lookup_primitive(char * name)
#define LD_CONF_NAME "ld.conf"
+#ifndef SYS_xen
static char * parse_ld_conf(void)
{
char * stdlib, * ldconfname, * config, * p, * q;
@@ -177,6 +180,8 @@ void caml_build_primitive_table(char * lib_path,
caml_ext_table_free(&caml_shared_libs_path, 0);
}
+#endif /* SYS_xen */
+
/* Build the table of primitives as a copy of the builtin primitive table.
Used for executables generated by ocamlc -output-obj. */
@@ -191,7 +196,7 @@ void caml_build_primitive_table_builtin(void)
#endif /* NATIVE_CODE */
/** dlopen interface for the bytecode linker **/
-
+#ifndef SYS_xen
#define Handle_val(v) (*((void **) (v)))
CAMLprim value caml_dynlink_open_lib(value mode, value filename)
@@ -265,3 +270,4 @@ value caml_dynlink_get_current_libs(value unit)
}
#endif /* NATIVE_CODE */
+#endif
View
170 lib/os/runtime_xen/ocaml/fail_bc.c
@@ -0,0 +1,170 @@
+/***********************************************************************/
+/* */
+/* Objective Caml */
+/* */
+/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
+/* */
+/* Copyright 1996 Institut National de Recherche en Informatique et */
+/* en Automatique. All rights reserved. This file is distributed */
+/* under the terms of the GNU Library General Public License, with */
+/* the special exception on linking described in file ../LICENSE. */
+/* */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Raising exceptions from C. */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include "alloc.h"
+#include "fail.h"
+#include "io.h"
+#include "gc.h"
+#include "memory.h"
+#include "misc.h"
+#include "mlvalues.h"
+#include "printexc.h"
+#include "signals.h"
+#include "stacks.h"
+
+CAMLexport struct longjmp_buffer * caml_external_raise = NULL;
+value caml_exn_bucket;
+
+CAMLexport void caml_raise(value v)
+{
+ Unlock_exn();
+ caml_exn_bucket = v;
+ if (caml_external_raise == NULL) caml_fatal_uncaught_exception(v);
+ siglongjmp(caml_external_raise->buf, 1);
+}
+
+CAMLexport void caml_raise_constant(value tag)
+{
+ CAMLparam1 (tag);
+ CAMLlocal1 (bucket);
+
+ bucket = caml_alloc_small (1, 0);
+ Field(bucket, 0) = tag;
+ caml_raise(bucket);
+ CAMLnoreturn;
+}
+
+CAMLexport void caml_raise_with_arg(value tag, value arg)
+{
+ CAMLparam2 (tag, arg);
+ CAMLlocal1 (bucket);
+
+ bucket = caml_alloc_small (2, 0);
+ Field(bucket, 0) = tag;
+ Field(bucket, 1) = arg;
+ caml_raise(bucket);
+ CAMLnoreturn;
+}
+
+CAMLexport void caml_raise_with_args(value tag, int nargs, value args[])
+{
+ CAMLparam1 (tag);
+ CAMLxparamN (args, nargs);
+ value bucket;
+ int i;
+
+ Assert(1 + nargs <= Max_young_wosize);
+ bucket = caml_alloc_small (1 + nargs, 0);
+ Field(bucket, 0) = tag;
+ for (i = 0; i < nargs; i++) Field(bucket, 1 + i) = args[i];
+ caml_raise(bucket);
+ CAMLnoreturn;
+}
+
+CAMLexport void caml_raise_with_string(value tag, char const *msg)
+{
+ CAMLparam1 (tag);
+ CAMLlocal1 (vmsg);
+
+ vmsg = caml_copy_string(msg);
+ caml_raise_with_arg(tag, vmsg);
+ CAMLnoreturn;
+}
+
+/* PR#5115: Failure and Invalid_argument can be triggered by
+ input_value while reading the initial value of [caml_global_data]. */
+
+CAMLexport void caml_failwith (char const *msg)
+{
+ if (caml_global_data == 0) {
+ fprintf(stderr, "Fatal error: exception Failure(\"%s\")\n", msg);
+ exit(2);
+ }
+ caml_raise_with_string(Field(caml_global_data, FAILURE_EXN), msg);
+}
+
+CAMLexport void caml_invalid_argument (char const *msg)
+{
+ if (caml_global_data == 0) {
+ fprintf(stderr, "Fatal error: exception Invalid_argument(\"%s\")\n", msg);
+ exit(2);
+ }
+ caml_raise_with_string(Field(caml_global_data, INVALID_EXN), msg);
+}
+
+CAMLexport void caml_array_bound_error(void)
+{
+ caml_invalid_argument("index out of bounds");
+}
+
+/* Problem: we can't use [caml_raise_constant], because it allocates and
+ we're out of memory... Here, we allocate statically the exn bucket
+ for [Out_of_memory]. */
+
+static struct {
+ header_t hdr;
+ value exn;
+} out_of_memory_bucket = { 0, 0 };
+
+CAMLexport void caml_raise_out_of_memory(void)
+{
+ if (out_of_memory_bucket.exn == 0)
+ caml_fatal_error
+ ("Fatal error: out of memory while raising Out_of_memory\n");
+ caml_raise((value) &(out_of_memory_bucket.exn));
+}
+
+CAMLexport void caml_raise_stack_overflow(void)
+{
+ caml_raise_constant(Field(caml_global_data, STACK_OVERFLOW_EXN));
+}
+
+CAMLexport void caml_raise_sys_error(value msg)
+{
+ caml_raise_with_arg(Field(caml_global_data, SYS_ERROR_EXN), msg);
+}
+
+CAMLexport void caml_raise_end_of_file(void)
+{
+ caml_raise_constant(Field(caml_global_data, END_OF_FILE_EXN));
+}
+
+CAMLexport void caml_raise_zero_divide(void)
+{
+ caml_raise_constant(Field(caml_global_data, ZERO_DIVIDE_EXN));
+}
+
+CAMLexport void caml_raise_not_found(void)
+{
+ caml_raise_constant(Field(caml_global_data, NOT_FOUND_EXN));
+}
+
+CAMLexport void caml_raise_sys_blocked_io(void)
+{
+ caml_raise_constant(Field(caml_global_data, SYS_BLOCKED_IO));
+}
+
+/* Initialization of statically-allocated exception buckets */
+
+void caml_init_exceptions(void)
+{
+ out_of_memory_bucket.hdr = Make_header(1, 0, Caml_white);
+ out_of_memory_bucket.exn = Field(caml_global_data, OUT_OF_MEMORY_EXN);
+ caml_register_global_root(&out_of_memory_bucket.exn);
+}
View
2 lib/os/runtime_xen/ocaml/interp.c
@@ -11,7 +11,7 @@
/* */
/***********************************************************************/
-/* $Id: interp.c 9547 2010-01-22 12:48:24Z doligez $ */
+/* $Id$ */
/* The bytecode interpreter */
#include <stdio.h>
View
37 lib/os/runtime_xen/ocaml/jumptbl.h
@@ -0,0 +1,37 @@
+ &&lbl_ACC0, &&lbl_ACC1, &&lbl_ACC2, &&lbl_ACC3, &&lbl_ACC4, &&lbl_ACC5, &&lbl_ACC6, &&lbl_ACC7,
+ &&lbl_ACC, &&lbl_PUSH,
+ &&lbl_PUSHACC0, &&lbl_PUSHACC1, &&lbl_PUSHACC2, &&lbl_PUSHACC3,
+ &&lbl_PUSHACC4, &&lbl_PUSHACC5, &&lbl_PUSHACC6, &&lbl_PUSHACC7,
+ &&lbl_PUSHACC, &&lbl_POP, &&lbl_ASSIGN,
+ &&lbl_ENVACC1, &&lbl_ENVACC2, &&lbl_ENVACC3, &&lbl_ENVACC4, &&lbl_ENVACC,
+ &&lbl_PUSHENVACC1, &&lbl_PUSHENVACC2, &&lbl_PUSHENVACC3, &&lbl_PUSHENVACC4, &&lbl_PUSHENVACC,
+ &&lbl_PUSH_RETADDR, &&lbl_APPLY, &&lbl_APPLY1, &&lbl_APPLY2, &&lbl_APPLY3,
+ &&lbl_APPTERM, &&lbl_APPTERM1, &&lbl_APPTERM2, &&lbl_APPTERM3,
+ &&lbl_RETURN, &&lbl_RESTART, &&lbl_GRAB,
+ &&lbl_CLOSURE, &&lbl_CLOSUREREC,
+ &&lbl_OFFSETCLOSUREM2, &&lbl_OFFSETCLOSURE0, &&lbl_OFFSETCLOSURE2, &&lbl_OFFSETCLOSURE,
+ &&lbl_PUSHOFFSETCLOSUREM2, &&lbl_PUSHOFFSETCLOSURE0,
+ &&lbl_PUSHOFFSETCLOSURE2, &&lbl_PUSHOFFSETCLOSURE,
+ &&lbl_GETGLOBAL, &&lbl_PUSHGETGLOBAL, &&lbl_GETGLOBALFIELD, &&lbl_PUSHGETGLOBALFIELD, &&lbl_SETGLOBAL,
+ &&lbl_ATOM0, &&lbl_ATOM, &&lbl_PUSHATOM0, &&lbl_PUSHATOM,
+ &&lbl_MAKEBLOCK, &&lbl_MAKEBLOCK1, &&lbl_MAKEBLOCK2, &&lbl_MAKEBLOCK3, &&lbl_MAKEFLOATBLOCK,
+ &&lbl_GETFIELD0, &&lbl_GETFIELD1, &&lbl_GETFIELD2, &&lbl_GETFIELD3, &&lbl_GETFIELD, &&lbl_GETFLOATFIELD,
+ &&lbl_SETFIELD0, &&lbl_SETFIELD1, &&lbl_SETFIELD2, &&lbl_SETFIELD3, &&lbl_SETFIELD, &&lbl_SETFLOATFIELD,
+ &&lbl_VECTLENGTH, &&lbl_GETVECTITEM, &&lbl_SETVECTITEM,
+ &&lbl_GETSTRINGCHAR, &&lbl_SETSTRINGCHAR,
+ &&lbl_BRANCH, &&lbl_BRANCHIF, &&lbl_BRANCHIFNOT, &&lbl_SWITCH, &&lbl_BOOLNOT,
+ &&lbl_PUSHTRAP, &&lbl_POPTRAP, &&lbl_RAISE, &&lbl_CHECK_SIGNALS,
+ &&lbl_C_CALL1, &&lbl_C_CALL2, &&lbl_C_CALL3, &&lbl_C_CALL4, &&lbl_C_CALL5, &&lbl_C_CALLN,
+ &&lbl_CONST0, &&lbl_CONST1, &&lbl_CONST2, &&lbl_CONST3, &&lbl_CONSTINT,
+ &&lbl_PUSHCONST0, &&lbl_PUSHCONST1, &&lbl_PUSHCONST2, &&lbl_PUSHCONST3, &&lbl_PUSHCONSTINT,
+ &&lbl_NEGINT, &&lbl_ADDINT, &&lbl_SUBINT, &&lbl_MULINT, &&lbl_DIVINT, &&lbl_MODINT,
+ &&lbl_ANDINT, &&lbl_ORINT, &&lbl_XORINT, &&lbl_LSLINT, &&lbl_LSRINT, &&lbl_ASRINT,
+ &&lbl_EQ, &&lbl_NEQ, &&lbl_LTINT, &&lbl_LEINT, &&lbl_GTINT, &&lbl_GEINT,
+ &&lbl_OFFSETINT, &&lbl_OFFSETREF, &&lbl_ISINT,
+ &&lbl_GETMETHOD,
+ &&lbl_BEQ, &&lbl_BNEQ, &&lbl_BLTINT, &&lbl_BLEINT, &&lbl_BGTINT, &&lbl_BGEINT,
+ &&lbl_ULTINT, &&lbl_UGEINT,
+ &&lbl_BULTINT, &&lbl_BUGEINT,
+ &&lbl_GETPUBMET, &&lbl_GETDYNMET,
+ &&lbl_STOP,
+ &&lbl_EVENT, &&lbl_BREAK
View
42 lib/os/runtime_xen/ocaml/libcamlrun.cclib
@@ -0,0 +1,42 @@
+amd64.bc.o
+alloc.bc.o
+array.bc.o
+backtrace.bc.o
+callback.bc.o
+compact.bc.o
+compare.bc.o
+custom.bc.o
+debugger.bc.o
+dynlink.bc.o
+extern.bc.o
+fail.bc.o
+finalise.bc.o
+floats.bc.o
+freelist.bc.o
+gc_ctrl.bc.o
+globroots.bc.o
+hash.bc.o
+instrtrace.bc.o
+intern.bc.o
+ints.bc.o
+io.bc.o
+lexing.bc.o
+main.bc.o
+major_gc.bc.o
+md5.bc.o
+memory.bc.o
+meta.bc.o
+minor_gc.bc.o
+misc.bc.o
+natdynlink.bc.o
+obj.bc.o
+parsing.bc.o
+printexc.bc.o
+roots.bc.o
+signals.bc.o
+stacks.bc.o
+startup_bc.bc.o
+str.bc.o
+sys.bc.o
+terminfo.bc.o
+weak.bc.o
View
82 lib/os/runtime_xen/ocaml/libocaml.cclib
@@ -1,42 +1,42 @@
amd64.o
-alloc.o
-array.o
-backtrace.o
-callback.o
-compact.o
-compare.o
-custom.o
-debugger.o
-dynlink.o
-extern.o
-fail.o
-finalise.o
-floats.o
-freelist.o
-gc_ctrl.o
-globroots.o
-hash.o
-intern.o
-ints.o
-io.o
-lexing.o
-main.o
-major_gc.o
-md5.o
-memory.o
-meta.o
-minor_gc.o
-misc.o
-natdynlink.o
-obj.o
-parsing.o
-printexc.o
-roots.o
-signals_asm.o
-signals.o
-stacks.o
-startup.o
-str.o
-sys.o
-weak.o
-bigarray_stubs.o
+alloc.nc.o
+array.nc.o
+backtrace.nc.o
+callback.nc.o
+compact.nc.o
+compare.nc.o
+custom.nc.o
+debugger.nc.o
+dynlink.nc.o
+extern.nc.o
+fail.nc.o
+finalise.nc.o
+floats.nc.o
+freelist.nc.o
+gc_ctrl.nc.o
+globroots.nc.o
+hash.nc.o
+intern.nc.o
+ints.nc.o
+io.nc.o
+lexing.nc.o
+main.nc.o
+major_gc.nc.o
+md5.nc.o
+memory.nc.o
+meta.nc.o
+minor_gc.nc.o
+misc.nc.o
+natdynlink.nc.o
+obj.nc.o
+parsing.nc.o
+printexc.nc.o
+roots.nc.o
+signals_asm.nc.o
+signals.nc.o
+stacks.nc.o
+startup.nc.o
+str.nc.o
+sys.nc.o
+weak.nc.o
+bigarray_stubs.nc.o
View
43 lib/os/runtime_xen/ocaml/libocamlbc.cclib
@@ -0,0 +1,43 @@
+alloc.bc.o
+array.bc.o
+callback.bc.o
+compact.bc.o
+compare.bc.o
+custom.bc.o
+debugger.bc.o
+dynlink.bc.o
+extern.bc.o
+fail_bc.bc.o
+finalise.bc.o
+floats.bc.o
+freelist.bc.o
+gc_ctrl.bc.o
+globroots.bc.o
+hash.bc.o
+intern.bc.o
+interp.bc.o
+ints.bc.o
+io.bc.o
+lexing.bc.o
+main.bc.o
+major_gc.bc.o
+md5.bc.o
+memory.bc.o
+meta.bc.o
+minor_gc.bc.o
+misc.bc.o
+natdynlink.bc.o
+obj.bc.o
+parsing.bc.o
+printexc.bc.o
+roots_bc.bc.o
+signals_byt.bc.o
+signals.bc.o
+stacks.bc.o
+str.bc.o
+sys.bc.o
+fix_code.bc.o
+weak.bc.o
+bigarray_stubs.bc.o
+startup_bc.bc.o
+backtrace_bc.bc.o
View
103 lib/os/runtime_xen/ocaml/roots_bc.c
@@ -0,0 +1,103 @@
+/***********************************************************************/
+/* */
+/* Objective Caml */
+/* */
+/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */
+/* */
+/* Copyright 1996 Institut National de Recherche en Informatique et */
+/* en Automatique. All rights reserved. This file is distributed */
+/* under the terms of the GNU Library General Public License, with */
+/* the special exception on linking described in file ../LICENSE. */
+/* */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* To walk the memory roots for garbage collection */
+
+#include "finalise.h"
+#include "globroots.h"
+#include "major_gc.h"
+#include "memory.h"
+#include "minor_gc.h"
+#include "misc.h"
+#include "mlvalues.h"
+#include "roots.h"
+#include "stacks.h"
+
+CAMLexport struct caml__roots_block *caml_local_roots = NULL;
+
+CAMLexport void (*caml_scan_roots_hook) (scanning_action f) = NULL;
+
+/* FIXME should rename to [caml_oldify_young_roots] and synchronise with
+ asmrun/roots.c */
+/* Call [caml_oldify_one] on (at least) all the roots that point to the minor
+ heap. */
+void caml_oldify_local_roots (void)
+{
+ register value * sp;
+ struct caml__roots_block *lr;
+ intnat i, j;
+
+ /* The stack */
+ for (sp = caml_extern_sp; sp < caml_stack_high; sp++) {
+ caml_oldify_one (*sp, sp);
+ }
+ /* Local C roots */ /* FIXME do the old-frame trick ? */
+ for (lr = caml_local_roots; lr != NULL; lr = lr->next) {
+ for (i = 0; i < lr->ntables; i++){
+ for (j = 0; j < lr->nitems; j++){
+ sp = &(lr->tables[i][j]);
+ caml_oldify_one (*sp, sp);
+ }
+ }
+ }
+ /* Global C roots */
+ caml_scan_global_young_roots(&caml_oldify_one);
+ /* Finalised values */
+ caml_final_do_young_roots (&caml_oldify_one);
+ /* Hook */
+ if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(&caml_oldify_one);
+}
+
+/* Call [caml_darken] on all roots */
+
+void caml_darken_all_roots (void)
+{
+ caml_do_roots (caml_darken);
+}
+
+void caml_do_roots (scanning_action f)
+{
+ /* Global variables */
+ f(caml_global_data, &caml_global_data);
+ /* The stack and the local C roots */
+ caml_do_local_roots(f, caml_extern_sp, caml_stack_high, caml_local_roots);
+ /* Global C roots */
+ caml_scan_global_roots(f);
+ /* Finalised values */
+ caml_final_do_strong_roots (f);
+ /* Hook */
+ if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(f);
+}
+
+CAMLexport void caml_do_local_roots (scanning_action f, value *stack_low,
+ value *stack_high,
+ struct caml__roots_block *local_roots)
+{
+ register value * sp;
+ struct caml__roots_block *lr;
+ int i, j;
+
+ for (sp = stack_low; sp < stack_high; sp++) {
+ f (*sp, sp);
+ }
+ for (lr = local_roots; lr != NULL; lr = lr->next) {
+ for (i = 0; i < lr->ntables; i++){
+ for (j = 0; j < lr->nitems; j++){
+ sp = &(lr->tables[i][j]);
+ f (*sp, sp);
+ }
+ }
+ }
+}
View
95 lib/os/runtime_xen/ocaml/signals_byt.c
@@ -0,0 +1,95 @@
+/***********************************************************************/
+/* */
+/* Objective Caml */
+/* */
+/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */
+/* */
+/* Copyright 2007 Institut National de Recherche en Informatique et */
+/* en Automatique. All rights reserved. This file is distributed */
+/* under the terms of the GNU Library General Public License, with */
+/* the special exception on linking described in file ../LICENSE. */
+/* */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Signal handling, code specific to the bytecode interpreter */
+
+#include <signal.h>
+#include "config.h"
+#include "memory.h"
+#include "osdeps.h"
+#include "signals.h"
+#include "signals_machdep.h"
+
+#ifndef NSIG
+#define NSIG 64
+#endif
+
+#ifdef _WIN32
+typedef void (*sighandler)(int sig);
+extern sighandler caml_win32_signal(int sig, sighandler action);
+#define signal(sig,act) caml_win32_signal(sig,act)
+#endif
+
+CAMLexport int volatile caml_something_to_do = 0;
+CAMLexport void (* volatile caml_async_action_hook)(void) = NULL;
+
+void caml_process_event(void)
+{
+ void (*async_action)(void);
+
+ if (caml_force_major_slice) caml_minor_collection ();
+ /* FIXME should be [caml_check_urgent_gc] */
+ caml_process_pending_signals();
+ async_action = caml_async_action_hook;
+ if (async_action != NULL) {
+ caml_async_action_hook = NULL;
+ (*async_action)();
+ }
+}
+
+static void handle_signal(int signal_number)
+{
+#if !defined(POSIX_SIGNALS) && !defined(BSD_SIGNALS)
+ signal(signal_number, handle_signal);
+#endif
+ if (signal_number < 0 || signal_number >= NSIG) return;
+ if (caml_try_leave_blocking_section_hook()) {
+ caml_execute_signal(signal_number, 1);
+ caml_enter_blocking_section_hook();
+ }else{
+ caml_record_signal(signal_number);
+ }
+}
+
+int caml_set_signal_action(int signo, int action)
+{
+ void (*act)(int signo), (*oldact)(int signo);
+#ifdef POSIX_SIGNALS
+ struct sigaction sigact, oldsigact;
+#endif
+
+ switch (action) {
+ case 0: act = SIG_DFL; break;
+ case 1: act = SIG_IGN; break;
+ default: act = handle_signal; break;
+ }
+
+#ifdef POSIX_SIGNALS
+ sigact.sa_handler = act;
+ sigemptyset(&sigact.sa_mask);
+ sigact.sa_flags = 0;
+ if (sigaction(signo, &sigact, &oldsigact) == -1) return -1;
+ oldact = oldsigact.sa_handler;
+#else
+ oldact = signal(signo, act);
+ if (oldact == SIG_ERR) return -1;
+#endif
+ if (oldact == handle_signal)
+ return 2;
+ else if (oldact == SIG_IGN)
+ return 1;
+ else
+ return 0;
+}
View
511 lib/os/runtime_xen/ocaml/startup_bc.c
@@ -0,0 +1,511 @@
+/***********************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */
+/* */
+/* Copyright 1996 Institut National de Recherche en Informatique et */
+/* en Automatique. All rights reserved. This file is distributed */
+/* under the terms of the GNU Library General Public License, with */
+/* the special exception on linking described in file ../LICENSE. */
+/* */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Start-up code */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <fcntl.h>
+#include "config.h"
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+#ifdef _WIN32
+#include <process.h>
+#endif
+#include "alloc.h"
+#include "backtrace.h"
+#include "callback.h"
+#include "custom.h"
+#include "debugger.h"
+#include "dynlink.h"
+#include "exec.h"
+#include "fail.h"
+#include "fix_code.h"
+#include "freelist.h"
+#include "gc_ctrl.h"
+#include "instrtrace.h"
+#include "interp.h"
+#include "intext.h"
+#include "io.h"
+#include "memory.h"
+#include "minor_gc.h"
+#include "misc.h"
+#include "mlvalues.h"
+#include "osdeps.h"
+#include "prims.h"
+#include "printexc.h"
+#include "reverse.h"
+#include "signals.h"
+#include "stacks.h"
+#include "sys.h"
+#include "startup.h"
+#include "version.h"
+
+#ifndef O_BINARY
+#define O_BINARY 0
+#endif
+
+#ifndef SEEK_END
+#define SEEK_END 2
+#endif
+
+extern int caml_parser_trace;
+
+CAMLexport header_t caml_atom_table[256];
+
+/* Initialize the atom table */
+
+static void init_atoms(void)
+{
+ int i;
+ for(i = 0; i < 256; i++) caml_atom_table[i] = Make_header(0, i, Caml_white);
+ if (caml_page_table_add(In_static_data,
+ caml_atom_table, caml_atom_table + 256) != 0) {
+ caml_fatal_error("Fatal error: not enough memory for the initial page table");
+ }
+}
+
+/* Read the trailer of a bytecode file */
+
+static void fixup_endianness_trailer(uint32 * p)
+{
+#ifndef ARCH_BIG_ENDIAN
+ Reverse_32(p, p);
+#endif
+}
+
+static int read_trailer(int fd, struct exec_trailer *trail)
+{
+ lseek(fd, (long) -TRAILER_SIZE, SEEK_END);
+ if (read(fd, (char *) trail, TRAILER_SIZE) < TRAILER_SIZE)
+ return BAD_BYTECODE;
+ fixup_endianness_trailer(&trail->num_sections);
+ if (strncmp(trail->magic, EXEC_MAGIC, 12) == 0)
+ return 0;
+ else
+ return BAD_BYTECODE;
+}
+
+#ifndef SYS_xen
+int caml_attempt_open(char **name, struct exec_trailer *trail,
+ int do_open_script)
+{
+ char * truename;
+ int fd;
+ int err;
+ char buf [2];
+
+ truename = caml_search_exe_in_path(*name);
+ *name = truename;
+ caml_gc_message(0x100, "Opening bytecode executable %s\n",
+ (uintnat) truename);
+ fd = open(truename, O_RDONLY | O_BINARY);
+ if (fd == -1) {
+ caml_gc_message(0x100, "Cannot open file\n", 0);
+ return FILE_NOT_FOUND;
+ }
+ if (!do_open_script) {
+ err = read (fd, buf, 2);
+ if (err < 2 || (buf [0] == '#' && buf [1] == '!')) {
+ close(fd);
+ caml_gc_message(0x100, "Rejected #! script\n", 0);
+ return BAD_BYTECODE;
+ }
+ }
+ err = read_trailer(fd, trail);
+ if (err != 0) {
+ close(fd);
+ caml_gc_message(0x100, "Not a bytecode executable\n", 0);
+ return err;
+ }
+ return fd;
+}
+
+/* Read the section descriptors */
+
+void caml_read_section_descriptors(int fd, struct exec_trailer *trail)
+{
+ int toc_size, i;
+
+ toc_size = trail->num_sections * 8;
+ trail->section = caml_stat_alloc(toc_size);
+ lseek(fd, - (long) (TRAILER_SIZE + toc_size), SEEK_END);
+ if (read(fd, (char *) trail->section, toc_size) != toc_size)
+ caml_fatal_error("Fatal error: cannot read section table\n");
+ /* Fixup endianness of lengths */
+ for (i = 0; i < trail->num_sections; i++)
+ fixup_endianness_trailer(&(trail->section[i].len));
+}
+
+/* Position fd at the beginning of the section having the given name.
+ Return the length of the section data in bytes, or -1 if no section
+ found with that name. */
+
+int32 caml_seek_optional_section(int fd, struct exec_trailer *trail, char *name)
+{
+ long ofs;
+ int i;
+
+ ofs = TRAILER_SIZE + trail->num_sections * 8;
+ for (i = trail->num_sections - 1; i >= 0; i--) {
+ ofs += trail->section[i].len;
+ if (strncmp(trail->section[i].name, name, 4) == 0) {
+ lseek(fd, -ofs, SEEK_END);
+ return trail->section[i].len;
+ }
+ }
+ return -1;
+}
+
+/* Position fd at the beginning of the section having the given name.
+ Return the length of the section data in bytes. */
+
+int32 caml_seek_section(int fd, struct exec_trailer *trail, char *name)
+{
+ int32 len = caml_seek_optional_section(fd, trail, name);
+ if (len == -1)
+ caml_fatal_error_arg("Fatal_error: section `%s' is missing\n", name);
+ return len;
+}
+
+/* Read and return the contents of the section having the given name.
+ Add a terminating 0. Return NULL if no such section. */
+
+static char * read_section(int fd, struct exec_trailer *trail, char *name)
+{
+ int32 len;
+ char * data;
+
+ len = caml_seek_optional_section(fd, trail, name);
+ if (len == -1) return NULL;
+ data = caml_stat_alloc(len + 1);
+ if (read(fd, data, len) != len)
+ caml_fatal_error_arg("Fatal error: error reading section %s\n", name);
+ data[len] = 0;
+ return data;
+}
+#endif
+/* Invocation of ocamlrun: 4 cases.
+
+ 1. runtime + bytecode
+ user types: ocamlrun [options] bytecode args...
+ arguments: ocamlrun [options] bytecode args...
+
+ 2. bytecode script
+ user types: bytecode args...
+ 2a (kernel 1) arguments: ocamlrun ./bytecode args...
+ 2b (kernel 2) arguments: bytecode bytecode args...
+
+ 3. concatenated runtime and bytecode
+ user types: composite args...
+ arguments: composite args...
+
+Algorithm:
+ 1- If argument 0 is a valid byte-code file that does not start with #!,
+ then we are in case 3 and we pass the same command line to the
+ OCaml program.
+ 2- In all other cases, we parse the command line as:
+ (whatever) [options] bytecode args...
+ and we strip "(whatever) [options]" from the command line.
+
+*/
+
+/* Configuration parameters and flags */
+
+static uintnat percent_free_init = Percent_free_def;
+static uintnat max_percent_free_init = Max_percent_free_def;
+static uintnat minor_heap_init = Minor_heap_def;
+static uintnat heap_chunk_init = Heap_chunk_def;
+static uintnat heap_size_init = Init_heap_def;
+static uintnat max_stack_init = Max_stack_def;
+
+/* Parse options on the command line */
+#ifndef SYS_xen
+static int parse_command_line(char **argv)
+{
+ int i, j;
+
+ for(i = 1; argv[i] != NULL && argv[i][0] == '-'; i++) {
+ switch(argv[i][1]) {
+#ifdef DEBUG
+ case 't':
+ caml_trace_flag++;
+ break;
+#endif
+ case 'v':
+ if (!strcmp (argv[i], "-version")){
+ printf ("The OCaml runtime, version " OCAML_VERSION "\n");
+ exit (0);
+ }else if (!strcmp (argv[i], "-vnum")){
+ printf (OCAML_VERSION "\n");
+ exit (0);
+ }else{
+ caml_verb_gc = 0x001+0x004+0x008+0x010+0x020;
+ }
+ break;
+ case 'p':
+ for (j = 0; caml_names_of_builtin_cprim[j] != NULL; j++)
+ printf("%s\n", caml_names_of_builtin_cprim[j]);
+ exit(0);
+ break;
+ case 'b':
+ caml_record_backtrace(Val_true);
+ break;
+ case 'I':
+ if (argv[i + 1] != NULL) {
+ caml_ext_table_add(&caml_shared_libs_path, argv[i + 1]);
+ i++;
+ }
+ break;
+ default:
+ caml_fatal_error_arg("Unknown option %s.\n", argv[i]);
+ }
+ }
+ return i;
+}
+
+/* Parse the OCAMLRUNPARAM variable */
+/* The option letter for each runtime option is the first letter of the
+ last word of the ML name of the option (see [stdlib/gc.mli]).
+ Except for l (maximum stack size) and h (initial heap size).
+*/
+
+/* If you change these functions, see also their copy in asmrun/startup.c */
+
+static void scanmult (char *opt, uintnat *var)
+{
+ char mult = ' ';
+ unsigned int val;
+ sscanf (opt, "=%u%c", &val, &mult);
+ sscanf (opt, "=0x%x%c", &val, &mult);
+ switch (mult) {
+ case 'k': *var = (uintnat) val * 1024; break;
+ case 'M': *var = (uintnat) val * 1024 * 1024; break;
+ case 'G': *var = (uintnat) val * 1024 * 1024 * 1024; break;
+ default: *var = (uintnat) val; break;
+ }
+}
+
+static void parse_camlrunparam(void)
+{
+ char *opt = getenv ("OCAMLRUNPARAM");
+ uintnat p;
+
+ if (opt == NULL) opt = getenv ("CAMLRUNPARAM");
+
+ if (opt != NULL){
+ while (*opt != '\0'){
+ switch (*opt++){
+ case 's': scanmult (opt, &minor_heap_init); break;
+ case 'i': scanmult (opt, &heap_chunk_init); break;
+ case 'h': scanmult (opt, &heap_size_init); break;
+ case 'l': scanmult (opt, &max_stack_init); break;
+ case 'o': scanmult (opt, &percent_free_init); break;
+ case 'O': scanmult (opt, &max_percent_free_init); break;
+ case 'v': scanmult (opt, &caml_verb_gc); break;
+ case 'b': caml_record_backtrace(Val_true); break;
+ case 'p': caml_parser_trace = 1; break;
+ case 'a': scanmult (opt, &p); caml_set_allocation_policy (p); break;
+ }
+ }
+ }
+}
+#endif /* SYS_xen */
+
+extern void caml_init_ieee_floats (void);
+
+#ifdef _WIN32
+extern void caml_signal_thread(void * lpParam);
+#endif
+
+#ifndef SYS_xen
+/* Main entry point when loading code from a file */
+
+CAMLexport void caml_main(char **argv)
+{
+ int fd, pos;
+ struct exec_trailer trail;
+ struct channel * chan;
+ value res;
+ char * shared_lib_path, * shared_libs, * req_prims;
+ char * exe_name;
+#ifdef __linux__
+ static char proc_self_exe[256];
+#endif
+
+ /* Machine-dependent initialization of the floating-point hardware
+ so that it behaves as much as possible as specified in IEEE */
+ caml_init_ieee_floats();
+ caml_init_custom_operations();
+ caml_ext_table_init(&caml_shared_libs_path, 8);
+ caml_external_raise = NULL;
+ /* Determine options and position of bytecode file */
+#ifdef DEBUG
+ caml_verb_gc = 0xBF;
+#endif
+ parse_camlrunparam();
+ pos = 0;
+ exe_name = argv[0];
+#ifdef __linux__
+ if (caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0)
+ exe_name = proc_self_exe;
+#endif
+ fd = caml_attempt_open(&exe_name, &trail, 0);
+ if (fd < 0) {
+ pos = parse_command_line(argv);
+ if (argv[pos] == 0)
+ caml_fatal_error("No bytecode file specified.\n");
+ exe_name = argv[pos];
+ fd = caml_attempt_open(&exe_name, &trail, 1);
+ switch(fd) {
+ case FILE_NOT_FOUND:
+ caml_fatal_error_arg("Fatal error: cannot find file %s\n", argv[pos]);
+ break;
+ case BAD_BYTECODE:
+ caml_fatal_error_arg(
+ "Fatal error: the file %s is not a bytecode executable file\n",
+ argv[pos]);
+ break;
+ }
+ }
+ /* Read the table of contents (section descriptors) */
+ caml_read_section_descriptors(fd, &trail);
+ /* Initialize the abstract machine */
+ caml_init_gc (minor_heap_init, heap_size_init, heap_chunk_init,
+ percent_free_init, max_percent_free_init);
+ caml_init_stack (max_stack_init);
+ init_atoms();
+ /* Initialize the interpreter */
+ caml_interprete(NULL, 0);
+ /* Initialize the debugger, if needed */
+ caml_debugger_init();
+ /* Load the code */
+ caml_code_size = caml_seek_section(fd, &trail, "CODE");
+ caml_load_code(fd, caml_code_size);
+ /* Build the table of primitives */
+ shared_lib_path = read_section(fd, &trail, "DLPT");
+ shared_libs = read_section(fd, &trail, "DLLS");
+ req_prims = read_section(fd, &trail, "PRIM");
+ if (req_prims == NULL) caml_fatal_error("Fatal error: no PRIM section\n");
+ caml_build_primitive_table(shared_lib_path, shared_libs, req_prims);
+ caml_stat_free(shared_lib_path);
+ caml_stat_free(shared_libs);
+ caml_stat_free(req_prims);
+ /* Load the globals */
+ caml_seek_section(fd, &trail, "DATA");
+ chan = caml_open_descriptor_in(fd);
+ caml_global_data = caml_input_val(chan);
+ caml_close_channel(chan); /* this also closes fd */
+ caml_stat_free(trail.section);
+ /* Ensure that the globals are in the major heap. */
+ caml_oldify_one (caml_global_data, &caml_global_data);
+ caml_oldify_mopup ();
+ /* Initialize system libraries */
+ caml_init_exceptions();
+ caml_sys_init(exe_name, argv + pos);
+#ifdef _WIN32
+ /* Start a thread to handle signals */
+ if (getenv("CAMLSIGPIPE"))
+ _beginthread(caml_signal_thread, 4096, NULL);
+#endif
+ /* Execute the program */
+ caml_debugger(PROGRAM_START);
+ res = caml_interprete(caml_start_code, caml_code_size);
+ if (Is_exception_result(res)) {
+ caml_exn_bucket = Extract_exception(res);
+ if (caml_debugger_in_use) {
+ caml_extern_sp = &caml_exn_bucket; /* The debugger needs the
+ exception value.*/
+ caml_debugger(UNCAUGHT_EXC);
+ }
+ caml_fatal_uncaught_exception(caml_exn_bucket);
+ }
+}
+#endif
+
+/* Main entry point when code is linked in as initialized data */
+
+CAMLexport void caml_startup_code(
+ code_t code, asize_t code_size,
+ char *data, asize_t data_size,
+ char *section_table, asize_t section_table_size,
+ char **argv)
+{
+ value res;
+ char* cds_file;
+
+ caml_init_ieee_floats();
+ caml_init_custom_operations();
+#ifdef DEBUG
+ caml_verb_gc = 63;
+#endif
+#ifndef SYS_xen
+ cds_file = getenv("CAML_DEBUG_FILE");
+ if (cds_file != NULL) {
+ caml_cds_file = caml_stat_alloc(strlen(cds_file) + 1);
+ strcpy(caml_cds_file, cds_file);
+ }
+ parse_camlrunparam();
+#endif
+ caml_external_raise = NULL;
+ /* Initialize the abstract machine */
+ caml_init_gc (minor_heap_init, heap_size_init, heap_chunk_init,
+ percent_free_init, max_percent_free_init);
+ caml_init_stack (max_stack_init);
+ init_atoms();
+ /* Initialize the interpreter */
+ caml_interprete(NULL, 0);
+ /* Initialize the debugger, if needed */
+ caml_debugger_init();
+ /* Load the code */
+ caml_start_code = code;
+ caml_code_size = code_size;
+ if (caml_debugger_in_use) {
+ int len, i;
+ len = code_size / sizeof(opcode_t);
+ caml_saved_code = (unsigned char *) caml_stat_alloc(len);
+ for (i = 0; i < len; i++) caml_saved_code[i] = caml_start_code[i];
+ }
+#ifdef THREADED_CODE
+ caml_thread_code(caml_start_code, code_size);
+#endif
+ /* Use the builtin table of primitives */
+ caml_build_primitive_table_builtin();
+ /* Load the globals */
+ caml_global_data = caml_input_value_from_block(data, data_size);
+ /* Ensure that the globals are in the major heap. */
+ caml_oldify_one (caml_global_data, &caml_global_data);
+ caml_oldify_mopup ();
+ /* Record the sections (for caml_get_section_table in meta.c) */
+ caml_section_table = section_table;
+ caml_section_table_size = section_table_size;
+ /* Initialize system libraries */
+ caml_init_exceptions();
+ caml_sys_init("", argv);
+ /* Execute the program */
+ caml_debugger(PROGRAM_START);
+ res = caml_interprete(caml_start_code, caml_code_size);
+ if (Is_exception_result(res)) {
+ caml_exn_bucket = Extract_exception(res);
+ if (caml_debugger_in_use) {
+ caml_extern_sp = &caml_exn_bucket; /* The debugger needs the
+ exception value.*/
+ caml_debugger(UNCAUGHT_EXC);
+ }
+ caml_fatal_uncaught_exception(caml_exn_bucket);
+ }
+}
View
1 lib/os/runtime_xen/ocaml/version.h
@@ -0,0 +1 @@
+#define OCAML_VERSION "3.12.1"
View
1 lib/unix.itarget
@@ -1,4 +1,5 @@
std/stdlib.cmxa
+std/stdlib.cma
os/runtime_unix/libunixrun.a
os/runtime_unix/main.o
annots
View
1 lib/xen.itarget
@@ -1,3 +1,4 @@
std/stdlib.cmxa
+std/stdlib.cma
os/runtime_xen/all.otarget
annots
View
72 scripts/myocamlbuild.ml
@@ -83,29 +83,38 @@ end
module Mir = struct
(** Link to a UNIX executable binary *)
- let cc_unix_link tags arg out env =
+ let cc_unix_link bc tags arg out env =
let ocamlc_libdir = "-L" ^ (Lazy.force stdlib_dir) in
let open OS in
let unixrun mode = lib / mode / "lib" / "libunixrun.a" in
let unixmain mode = lib / mode / "lib" / "main.o" in
let mode = sprintf "unix-%s" (env "%(mode)") in
+ let asmlib = match bc with |true -> A"-lcamlrun" |false -> A"-lasmrun" in
let dl_libs = match host with
- |Linux -> [A"-lm"; A"-lasmrun"; A"-lcamlstr"; A"-ldl"]
- |Darwin |FreeBSD -> [A"-lm"; A"-lasmrun"; A"-lcamlstr"] in
+ |Linux -> [A"-lm"; asmlib; A"-lcamlstr"; A"-ldl"; A"-ltermcap"]
+ |Darwin |FreeBSD -> [A"-lm"; asmlib; A"-lcamlstr"] in
let tags = tags++"cc"++"c" in
Cmd (S (A cc :: [ T(tags++"link"); A ocamlc_libdir; A"-o"; Px out;
A (unixmain mode); P arg; A (unixrun mode); ] @ dl_libs))
+ let cc_unix_bytecode_link = cc_unix_link true
+ let cc_unix_native_link = cc_unix_link false
+
(** Link to a standalone Xen microkernel *)
- let cc_xen_link tags arg out env =
+ let cc_xen_link bc tags arg out env =
let xenlib = lib / "xen" / "lib" in
+ let jmp_obj = Px (xenlib / "longjmp.o") in
let head_obj = Px (xenlib / "x86_64.o") in
+ let ocamllib = match bc with true -> "ocamlbc" |false -> "ocaml" in
let ldlibs = List.map (fun x -> Px (xenlib / ("lib" ^ x ^ ".a")))
- ["ocaml"; "xen"; "xencaml"; "diet"; "m"] in
+ [ocamllib; "xen"; "xencaml"; "diet"; "m"] in
Cmd (S ( A ld :: [ T(tags++"link"++"xen");
A"-d"; A"-nostdlib"; A"-m"; A"elf_x86_64"; A"-T";
- Px (xenlib / "mirage-x86_64.lds"); head_obj; P arg ]
- @ ldlibs @ [A"-o"; Px out]))
+ Px (xenlib / "mirage-x86_64.lds"); head_obj; P arg ]
+ @ ldlibs @ [jmp_obj; A"-o"; Px out]))
+
+ let cc_xen_bc_link = cc_xen_link true
+ let cc_xen_nc_link = cc_xen_link false
(* Rewrite sections for Xen LDS layout *)
let xen_objcopy dst src env builder =
@@ -115,6 +124,13 @@ module Mir = struct
let cmds = List.map (fun x -> A x) cmd in
Cmd (S (cmds @ [Px src; Px dst]))
+ (* ocamlclean a bytecode c into a smaller one *)
+ let ocamlclean dst src env builder =
+ let dst = env dst in
+ let src = env src in
+ let cmd = [A"ocamlclean"; A"-verbose"; A"-o"; Px dst; Px src] in
+ Cmd (S cmd)
+
(** Generic CC linking rule that wraps both Xen and C *)
let cc_link_c_implem ?tag fn c o env build =
let c = env c and o = env o in
@@ -148,6 +164,11 @@ module Mir = struct
ocamlopt_link_prog
(fun tags -> tags++"ocaml"++"link"++"native"++"output_obj") x
+ let bytecode_output_obj x =
+ link_gen "cmo" "cma" !Options.ext_lib [!Options.ext_obj; "cmi"]
+ ocamlc_link_prog
+ (fun tags -> tags++"ocaml"++"link"++"byte"++"output_obj") x
+
(** Generate all the rules for mir *)
let rules () =
(* Copied from ocaml/ocamlbuild/ocaml_specific.ml *)
@@ -166,23 +187,54 @@ module Mir = struct
~deps:["%.cmx"; x_o]
(native_output_obj "%.cmx" "%.m.o");
+ (* Rule to link a module and output a standalone bytecode C file *)
+ rule "ocaml: cmo* & o* -> .mb.c"
+ ~prod:"%.mb.c"
+ ~deps:["%.cmo"; x_o]
+ (bytecode_output_obj "%.cmo" "%.mb.c");
+
+ (* Rule to ocamlclean a C file into a crunched version.
+ * Requires avsm/ocamlclean from github *)
+ rule "ocaml: .mb.c -> .mc.c"
+ ~prod:"%.mc.c"
+ ~dep:"%.mb.c"
+ (ocamlclean "%.mc.c" "%.mb.c");
+
(* Rule to rename module sections to ml* equivalents for the static vmem layout *)
rule "ocaml: .m.o -> .mx.o"
~prod:"%.mx.o"
~dep:"%.m.o"
(xen_objcopy "%.mx.o" "%.m.o");
(* Xen link rule *)
- rule ("final link: xen/%__.m.o -> xen/%.xen")
+ rule ("final link: xen/%__.mx.o -> xen/%.xen")
~prod:"xen/%(file).xen"
~dep:"xen/%(file)__.mx.o"
- (cc_link_c_implem cc_xen_link "xen/%(file)__.mx.o" "xen/%(file).xen");
+ (cc_link_c_implem cc_xen_nc_link "xen/%(file)__.mx.o" "xen/%(file).xen");
+
+ (* Xen bytecode link rule *)
+ rule ("final link: xen/%__.mb.o -> xen/%.bcxen")
+ ~prod:"xen/%(file).bcxen"
+ ~dep:"xen/%(file)__.mc.o"
+ (cc_link_c_implem cc_xen_bc_link "xen/%(file)__.mc.o" "xen/%(file).bcxen");
(* UNIX link rule *)
rule ("final link: %__.m.o -> %.unix-%(mode).bin")
~prod:"unix-%(mode)/%(file).bin"
~dep:"unix-%(mode)/%(file)__.m.o"
- (cc_link_c_implem cc_unix_link "unix-%(mode)/%(file)__.m.o" "unix-%(mode)/%(file).bin");
+ (cc_link_c_implem cc_unix_native_link "unix-%(mode)/%(file)__.m.o" "unix-%(mode)/%(file).bin");
+
+ (* UNIX bytecode link rule with ocamlclean *)
+ rule ("final link: %__.mc.c -> %.unix-%(mode).bcxbin")
+ ~prod:"unix-%(mode)/%(file).bcxbin"
+ ~dep:"unix-%(mode)/%(file)__.mc.o"
+ (cc_link_c_implem cc_unix_bytecode_link "unix-%(mode)/%(file)__.mc.o" "unix-%(mode)/%(file).bcxbin");
+
+ (* UNIX bytecode link rule without ocamlclean *)
+ rule ("final link: %__.mb.c -> %.unix-%(mode).bcbin")
+ ~prod:"unix-%(mode)/%(file).bcbin"
+ ~dep:"unix-%(mode)/%(file)__.mb.o"
+ (cc_link_c_implem cc_unix_bytecode_link "unix-%(mode)/%(file)__.mb.o" "unix-%(mode)/%(file).bcbin");
(* Node link rule *)
rule ("final link: node/%__.byte -> node/%.js")

0 comments on commit 82b1692

Please sign in to comment.