Premier jet

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

5 files changed, 220 insertions, 0 deletions

diff --git a/otherlibs/dynlink/.depend b/otherlibs/dynlink/.depend
new file mode 100644
index 000000000..89f6b0fe9
--- /dev/null
+++ b/otherlibs/dynlink/.depend
@@ -0,0 +1,4 @@
+dynlink.cmo: dynlink.cmi 
+dynlink.cmx: dynlink.cmi 
+extract_crc.cmo: dynlink.cmi 
+extract_crc.cmx: dynlink.cmx 
diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile
new file mode 100644
index 000000000..554840c91
--- /dev/null
+++ b/otherlibs/dynlink/Makefile
@@ -0,0 +1,38 @@
+# Makefile for the dynamic link library
+
+include ../../Makefile.config
+
+CAMLC=../../boot/camlrun ../../boot/camlc
+INCLUDES=-I ../../utils -I ../../typing -I ../../bytecomp
+COMPFLAGS=-I ../../boot $(INCLUDES)
+
+OBJS=dynlink.cmo
+COMPILEROBJS=misc.cmo tbl.cmo clflags.cmo config.cmo ident.cmo predef.cmo \
+  runtimedef.cmo symtable.cmo opcodes.cmo
+
+all: dynlink.cma extract_crc
+
+dynlink.cma: $(OBJS)
+	$(CAMLC) $(COMPFLAGS) -a -o dynlink.cma $(COMPILEROBJS) $(OBJS)
+
+extract_crc: dynlink.cma extract_crc.cmo
+	$(CAMLC) $(COMPFLAGS) -o extract_crc dynlink.cma extract_crc.cmo
+
+install:
+	cp dynlink.cmi dynlink.cma extract_crc $(LIBDIR)
+
+clean:
+	rm -f extract_crc *.cm[ioa]
+
+.SUFFIXES: .ml .mli .cmo .cmi
+
+.mli.cmi:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmo:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+depend:
+	../../tools/camldep *.mli *.ml > .depend
+
+include .depend
diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml
new file mode 100644
index 000000000..017fe43f1
--- /dev/null
+++ b/otherlibs/dynlink/dynlink.ml
@@ -0,0 +1,127 @@
+(* Dynamic loading of .cmo files *)
+
+open Emitcode
+
+type error =
+    Not_a_bytecode_file of string
+  | Inconsistent_import of string
+  | Unavailable_unit of string
+  | Unauthorized_primitive of string
+  | Linking_error of string
+  | Corrupted_interface of string
+
+exception Error of error
+
+(* Initialize the linker tables and everything *)
+
+let init () =
+  Symtable.init_toplevel()  
+
+(* Check that the object file being loaded has been compiled against
+   the same interfaces as the program itself. In addition, check that
+   only authorized compilation units are referenced. *)
+
+let crc_interfaces = (Hashtbl.new 17 : (string, int) Hashtbl.t)
+
+let check_consistency file_name cu =
+  match cu.cu_interfaces with
+    [] ->
+      raise(Error(Not_a_bytecode_file file_name))
+  | (unit_name, unit_interface_crc) :: imports ->
+      List.iter
+	(fun (name, crc) ->
+	  try
+	    let auth_crc = Hashtbl.find crc_interfaces name in
+	    if crc <> auth_crc then
+	      raise(Error(Inconsistent_import name))
+	  with Not_found ->
+	    raise(Error(Unavailable_unit name)))
+	imports;
+      Hashtbl.add crc_interfaces unit_name unit_interface_crc
+
+(* Reset the crc_interfaces table *)
+
+let clear_available_units () =
+  Hashtbl.clear crc_interfaces
+
+(* Initialize the crc_interfaces table with a list of units with fixed CRCs *)
+
+let add_available_units units =
+  List.iter (fun (unit, crc) -> Hashtbl.add crc_interfaces unit crc) units
+
+(* Read the CRC of an interface from its .cmi file *)
+
+let crc_interface unit loadpath =
+  let filename = Misc.find_in_path loadpath (Misc.lowercase unit ^ ".cmi") in
+  let ic = open_in_bin filename in
+  try
+    let buffer = String.create (String.length Config.cmi_magic_number) in
+    really_input ic buffer 0 (String.length Config.cmi_magic_number);
+    if buffer <> Config.cmi_magic_number then begin
+      close_in ic;
+      raise(Error(Corrupted_interface filename))
+    end;
+    input_value ic;
+    let crc = input_binary_int ic in
+    close_in ic;
+    crc
+  with End_of_file | Failure _ ->
+    close_in ic;
+    raise(Error(Corrupted_interface filename))
+
+(* Initialize the crc_interfaces table with a list of units.
+   Their CRCs are read from their interfaces. *)
+
+let add_interfaces units loadpath =
+  add_available_units
+    (List.map (fun unit -> (unit, crc_interface unit loadpath)) units)
+
+(* Check that the object file being loaded does not call any unauthorized
+   C function directly *)
+
+let all_available_primitives() = Array.to_list(Meta.available_primitives())
+
+let safe_primitives = ref (all_available_primitives())
+
+let check_primitives cu =
+  List.iter
+    (function
+      	(Reloc_primitive p, pos) ->
+	    if not (List.mem p !safe_primitives) 
+      	    then raise(Error(Unauthorized_primitive p))
+     | _ -> ())
+    cu.cu_reloc
+
+let set_authorized_primitives primlist =
+  safe_primitives := primlist
+
+(* Load in-core and execute a bytecode object file *)
+
+let loadfile file_name =
+  let ic = open_in_bin file_name in
+  let buffer = String.create (String.length Config.cmo_magic_number) in
+  really_input ic buffer 0 (String.length Config.cmo_magic_number);
+  if buffer <> Config.cmo_magic_number then
+    raise(Error(Not_a_bytecode_file file_name));
+  let compunit_pos = input_binary_int ic in  (* Go to descriptor *)
+  seek_in ic compunit_pos;
+  let compunit = (input_value ic : compilation_unit) in
+  check_consistency file_name compunit;
+  check_primitives compunit;
+  seek_in ic compunit.cu_pos;
+  let code_size = compunit.cu_codesize + 4 in
+  let code = Meta.static_alloc code_size in
+  unsafe_really_input ic code 0 compunit.cu_codesize;
+  close_in ic;
+  String.unsafe_set code compunit.cu_codesize
+			     (Char.chr Opcodes.opSTOP);
+  String.unsafe_set code (compunit.cu_codesize + 1) '\000';
+  String.unsafe_set code (compunit.cu_codesize + 2) '\000';
+  String.unsafe_set code (compunit.cu_codesize + 3) '\000';
+  begin try
+    Symtable.patch_object code compunit.cu_reloc;
+    Symtable.update_global_table()
+  with Symtable.Error _ ->
+    raise(Error(Linking_error file_name))
+  end;
+  Meta.execute_bytecode code code_size; ()
diff --git a/otherlibs/dynlink/dynlink.mli b/otherlibs/dynlink/dynlink.mli
new file mode 100644
index 000000000..3141c97a2
--- /dev/null
+++ b/otherlibs/dynlink/dynlink.mli
@@ -0,0 +1,20 @@
+(* Dynamic loading of .cmo files *)
+
+val init : unit -> unit
+val loadfile : string -> unit
+val clear_available_units : unit -> unit
+val add_available_units : (string * int) list -> unit
+val crc_interface : string -> string list -> int
+val add_interfaces : string list -> string list -> unit
+val set_authorized_primitives: string list -> unit
+val all_available_primitives: unit -> string list
+
+type error =
+    Not_a_bytecode_file of string
+  | Inconsistent_import of string
+  | Unavailable_unit of string
+  | Unauthorized_primitive of string
+  | Linking_error of string
+  | Corrupted_interface of string
+
+exception Error of error
diff --git a/otherlibs/dynlink/extract_crc.ml b/otherlibs/dynlink/extract_crc.ml
new file mode 100644
index 000000000..222fd2fef
--- /dev/null
+++ b/otherlibs/dynlink/extract_crc.ml
@@ -0,0 +1,31 @@
+(* Read the CRC of the interfaces of the units *)
+
+let load_path = ref ["."]
+let first = ref true
+
+let print_crc unit =
+  try
+    let crc = Dynlink.crc_interface unit !load_path in
+    if !first then first := false else print_string ";\n";
+    print_string "  \""; print_string unit; print_string "\", ";
+    print_int crc
+  with exn ->
+    prerr_string "Error while reading the interface for ";
+    prerr_endline unit;
+    begin match exn with
+      Sys_error msg -> prerr_endline msg
+    | Dynlink.Error _ -> prerr_endline "Ill formed .cmi file"
+    | _ -> raise exn
+    end;
+    exit 2
+
+let main () =
+  print_string "let crc_unit_list = [\n";
+  Arg.parse
+    ["-I", Arg.String(fun dir -> load_path := !load_path @ [dir])]
+    print_crc;
+  print_string "\n]\n"
+
+let _ = main(); exit 0
+
+