diff options
Diffstat (limited to 'ocaml-binary-annot/toplevel')
20 files changed, 2616 insertions, 0 deletions
diff --git a/ocaml-binary-annot/toplevel/expunge.ml b/ocaml-binary-annot/toplevel/expunge.ml new file mode 100644 index 0000000000..5debb41243 --- /dev/null +++ b/ocaml-binary-annot/toplevel/expunge.ml @@ -0,0 +1,78 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* "Expunge" a toplevel by removing compiler modules from the global List.map. + Usage: expunge <source file> <dest file> <names of modules to keep> *) + +open Sys +open Misc + +module StringSet = + Set.Make(struct + type t = string + let compare = compare + end) + +let to_keep = ref StringSet.empty + +let expunge_map tbl = + Symtable.filter_global_map + (fun id -> StringSet.mem (Ident.name id) !to_keep) + tbl + +let expunge_crcs tbl = + List.filter (fun (unit, crc) -> StringSet.mem unit !to_keep) tbl + +let main () = + let input_name = Sys.argv.(1) in + let output_name = Sys.argv.(2) in + Array.iter + (fun exn -> to_keep := StringSet.add exn !to_keep) + Runtimedef.builtin_exceptions; + for i = 3 to Array.length Sys.argv - 1 do + to_keep := StringSet.add (String.capitalize Sys.argv.(i)) !to_keep + done; + let ic = open_in_bin input_name in + Bytesections.read_toc ic; + let toc = Bytesections.toc() in + let pos_first_section = Bytesections.pos_first_section ic in + let oc = + open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o777 + output_name in + (* Copy the file up to the symbol section as is *) + seek_in ic 0; + copy_file_chunk ic oc pos_first_section; + (* Copy each section, modifying the symbol section in passing *) + Bytesections.init_record oc; + List.iter + (fun (name, len) -> + begin match name with + "SYMB" -> + let global_map = (input_value ic : Symtable.global_map) in + output_value oc (expunge_map global_map) + | "CRCS" -> + let crcs = (input_value ic : (string * Digest.t) list) in + output_value oc (expunge_crcs crcs) + | _ -> + copy_file_chunk ic oc len + end; + Bytesections.record oc name) + toc; + (* Rewrite the toc and trailer *) + Bytesections.write_toc_and_trailer oc; + (* Done *) + close_in ic; + close_out oc + +let _ = Printexc.catch main (); exit 0 diff --git a/ocaml-binary-annot/toplevel/genprintval.ml b/ocaml-binary-annot/toplevel/genprintval.ml new file mode 100644 index 0000000000..3277004006 --- /dev/null +++ b/ocaml-binary-annot/toplevel/genprintval.ml @@ -0,0 +1,365 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy and Jerome Vouillon, 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* To print values *) + +open Misc +open Format +open Longident +open Path +open Types +open Outcometree + +module type OBJ = + sig + type t + val obj : t -> 'a + val is_block : t -> bool + val tag : t -> int + val size : t -> int + val field : t -> int -> t + end + +module type EVALPATH = + sig + type value + val eval_path: Path.t -> value + exception Error + val same_value: value -> value -> bool + end + +module type S = + sig + type t + val install_printer : + Path.t -> Types.type_expr -> (formatter -> t -> unit) -> unit + val remove_printer : Path.t -> unit + val outval_of_untyped_exception : t -> Outcometree.out_value + val outval_of_value : + int -> int -> + (int -> t -> Types.type_expr -> Outcometree.out_value option) -> + Env.t -> t -> type_expr -> Outcometree.out_value + end + +module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct + + type t = O.t + + (* Given an exception value, we cannot recover its type, + hence we cannot print its arguments in general. + Here, we do a feeble attempt to print + integer, string and float arguments... *) + let outval_of_untyped_exception_args obj start_offset = + if O.size obj > start_offset then begin + let list = ref [] in + for i = start_offset to O.size obj - 1 do + let arg = O.field obj i in + if not (O.is_block arg) then + list := Oval_int (O.obj arg : int) :: !list + (* Note: this could be a char or a constant constructor... *) + else if O.tag arg = Obj.string_tag then + list := + Oval_string (String.escaped (O.obj arg : string)) :: !list + else if O.tag arg = Obj.double_tag then + list := Oval_float (O.obj arg : float) :: !list + else + list := Oval_constr (Oide_ident "_", []) :: !list + done; + List.rev !list + end + else [] + + let outval_of_untyped_exception bucket = + let name = (O.obj(O.field(O.field bucket 0) 0) : string) in + let args = + if (name = "Match_failure" + || name = "Assert_failure" + || name = "Undefined_recursive_module") + && O.size bucket = 2 + && O.tag(O.field bucket 1) = 0 + then outval_of_untyped_exception_args (O.field bucket 1) 0 + else outval_of_untyped_exception_args bucket 1 in + Oval_constr (Oide_ident name, args) + + (* The user-defined printers. Also used for some builtin types. *) + + let printers = ref ([ + Pident(Ident.create "print_int"), Predef.type_int, + (fun x -> Oval_int (O.obj x : int)); + Pident(Ident.create "print_float"), Predef.type_float, + (fun x -> Oval_float (O.obj x : float)); + Pident(Ident.create "print_char"), Predef.type_char, + (fun x -> Oval_char (O.obj x : char)); + Pident(Ident.create "print_string"), Predef.type_string, + (fun x -> Oval_string (O.obj x : string)); + Pident(Ident.create "print_int32"), Predef.type_int32, + (fun x -> Oval_int32 (O.obj x : int32)); + Pident(Ident.create "print_nativeint"), Predef.type_nativeint, + (fun x -> Oval_nativeint (O.obj x : nativeint)); + Pident(Ident.create "print_int64"), Predef.type_int64, + (fun x -> Oval_int64 (O.obj x : int64)) + ] : (Path.t * type_expr * (O.t -> Outcometree.out_value)) list) + + let install_printer path ty fn = + let print_val ppf obj = + try fn ppf obj with + | exn -> + fprintf ppf "<printer %a raised an exception>" Printtyp.path path in + let printer obj = Oval_printer (fun ppf -> print_val ppf obj) in + printers := (path, ty, printer) :: !printers + + let remove_printer path = + let rec remove = function + | [] -> raise Not_found + | (p, ty, fn as printer) :: rem -> + if Path.same p path then rem else printer :: remove rem in + printers := remove !printers + + let find_printer env ty = + let rec find = function + | [] -> raise Not_found + | (name, sch, printer) :: remainder -> + if Ctype.moregeneral env false sch ty + then printer + else find remainder + in find !printers + + (* Print a constructor or label, giving it the same prefix as the type + it comes from. Attempt to omit the prefix if the type comes from + a module that has been opened. *) + + let tree_of_qualified lookup_fun env ty_path name = + match ty_path with + | Pident id -> + Oide_ident name + | Pdot(p, s, pos) -> + if try + match (lookup_fun (Lident name) env).desc with + | Tconstr(ty_path', _, _) -> Path.same ty_path ty_path' + | _ -> false + with Not_found -> false + then Oide_ident name + else Oide_dot (Printtyp.tree_of_path p, name) + | Papply(p1, p2) -> + Printtyp.tree_of_path ty_path + + let tree_of_constr = + tree_of_qualified + (fun lid env -> (Env.lookup_constructor lid env).cstr_res) + + and tree_of_label = + tree_of_qualified (fun lid env -> (Env.lookup_label lid env).lbl_res) + + (* An abstract type *) + + let abstract_type = + Ctype.newty (Tconstr (Pident (Ident.create "abstract"), [], ref Mnil)) + + (* The main printing function *) + + let outval_of_value max_steps max_depth check_depth env obj ty = + + let printer_steps = ref max_steps in + + let rec tree_of_val depth obj ty = + decr printer_steps; + if !printer_steps < 0 || depth < 0 then Oval_ellipsis + else begin + try + find_printer env ty obj + with Not_found -> + match (Ctype.repr ty).desc with + | Tvar -> + Oval_stuff "<poly>" + | Tarrow(_, ty1, ty2, _) -> + Oval_stuff "<fun>" + | Ttuple(ty_list) -> + Oval_tuple (tree_of_val_list 0 depth obj ty_list) + | Tconstr(path, [], _) when Path.same path Predef.path_exn -> + tree_of_exception depth obj + | Tconstr(path, [ty_arg], _) + when Path.same path Predef.path_list -> + if O.is_block obj then + match check_depth depth obj ty with + Some x -> x + | None -> + let rec tree_of_conses tree_list obj = + if !printer_steps < 0 || depth < 0 then + Oval_ellipsis :: tree_list + else if O.is_block obj then + let tree = + tree_of_val (depth - 1) (O.field obj 0) ty_arg in + let next_obj = O.field obj 1 in + tree_of_conses (tree :: tree_list) next_obj + else tree_list + in + Oval_list (List.rev (tree_of_conses [] obj)) + else + Oval_list [] + | Tconstr(path, [ty_arg], _) + when Path.same path Predef.path_array -> + let length = O.size obj in + if length > 0 then + match check_depth depth obj ty with + Some x -> x + | None -> + let rec tree_of_items tree_list i = + if !printer_steps < 0 || depth < 0 then + Oval_ellipsis :: tree_list + else if i < length then + let tree = + tree_of_val (depth - 1) (O.field obj i) ty_arg in + tree_of_items (tree :: tree_list) (i + 1) + else tree_list + in + Oval_array (List.rev (tree_of_items [] 0)) + else + Oval_array [] + | Tconstr (path, [ty_arg], _) + when Path.same path Predef.path_lazy_t -> + if Lazy.lazy_is_val (O.obj obj) + then let v = tree_of_val depth (Lazy.force (O.obj obj)) ty_arg in + Oval_constr (Oide_ident "lazy", [v]) + else Oval_stuff "<lazy>" + | Tconstr(path, ty_list, _) -> + begin try + let decl = Env.find_type path env in + match decl with + | {type_kind = Type_abstract; type_manifest = None} -> + Oval_stuff "<abstr>" + | {type_kind = Type_abstract; type_manifest = Some body} -> + tree_of_val depth obj + (try Ctype.apply env decl.type_params body ty_list with + Ctype.Cannot_apply -> abstract_type) + | {type_kind = Type_variant constr_list} -> + let tag = + if O.is_block obj + then Cstr_block(O.tag obj) + else Cstr_constant(O.obj obj) in + let (constr_name, constr_args) = + Datarepr.find_constr_by_tag tag constr_list in + let ty_args = + List.map + (function ty -> + try Ctype.apply env decl.type_params ty ty_list with + Ctype.Cannot_apply -> abstract_type) + constr_args in + tree_of_constr_with_args (tree_of_constr env path) + constr_name 0 depth obj ty_args + | {type_kind = Type_record(lbl_list, rep)} -> + begin match check_depth depth obj ty with + Some x -> x + | None -> + let rec tree_of_fields pos = function + | [] -> [] + | (lbl_name, _, lbl_arg) :: remainder -> + let ty_arg = + try + Ctype.apply env decl.type_params lbl_arg + ty_list + with + Ctype.Cannot_apply -> abstract_type in + let lid = tree_of_label env path lbl_name in + let v = + tree_of_val (depth - 1) (O.field obj pos) + ty_arg + in + (lid, v) :: tree_of_fields (pos + 1) remainder + in + Oval_record (tree_of_fields 0 lbl_list) + end + with + Not_found -> (* raised by Env.find_type *) + Oval_stuff "<abstr>" + | Datarepr.Constr_not_found -> (* raised by find_constr_by_tag *) + Oval_stuff "<unknown constructor>" + end + | Tvariant row -> + let row = Btype.row_repr row in + if O.is_block obj then + let tag : int = O.obj (O.field obj 0) in + let rec find = function + | (l, f) :: fields -> + if Btype.hash_variant l = tag then + match Btype.row_field_repr f with + | Rpresent(Some ty) | Reither(_,[ty],_,_) -> + let args = + tree_of_val (depth - 1) (O.field obj 1) ty in + Oval_variant (l, Some args) + | _ -> find fields + else find fields + | [] -> Oval_stuff "<variant>" in + find row.row_fields + else + let tag : int = O.obj obj in + let rec find = function + | (l, _) :: fields -> + if Btype.hash_variant l = tag then + Oval_variant (l, None) + else find fields + | [] -> Oval_stuff "<variant>" in + find row.row_fields + | Tobject (_, _) -> + Oval_stuff "<obj>" + | Tsubst ty -> + tree_of_val (depth - 1) obj ty + | Tfield(_, _, _, _) | Tnil | Tlink _ -> + fatal_error "Printval.outval_of_value" + | Tpoly (ty, _) -> + tree_of_val (depth - 1) obj ty + | Tunivar -> + Oval_stuff "<poly>" + | Tpackage _ -> + Oval_stuff "<module>" + end + + and tree_of_val_list start depth obj ty_list = + let rec tree_list i = function + | [] -> [] + | ty :: ty_list -> + let tree = tree_of_val (depth - 1) (O.field obj i) ty in + tree :: tree_list (i + 1) ty_list in + tree_list start ty_list + + and tree_of_constr_with_args + tree_of_cstr cstr_name start depth obj ty_args = + let lid = tree_of_cstr cstr_name in + let args = tree_of_val_list start depth obj ty_args in + Oval_constr (lid, args) + + and tree_of_exception depth bucket = + let name = (O.obj(O.field(O.field bucket 0) 0) : string) in + let lid = Longident.parse name in + try + (* Attempt to recover the constructor description for the exn + from its name *) + let cstr = Env.lookup_constructor lid env in + let path = + match cstr.cstr_tag with + Cstr_exception p -> p | _ -> raise Not_found in + (* Make sure this is the right exception and not an homonym, + by evaluating the exception found and comparing with the + identifier contained in the exception bucket *) + if not (EVP.same_value (O.field bucket 0) (EVP.eval_path path)) + then raise Not_found; + tree_of_constr_with_args + (fun x -> Oide_ident x) name 1 depth bucket cstr.cstr_args + with Not_found | EVP.Error -> + match check_depth depth bucket ty with + Some x -> x + | None -> outval_of_untyped_exception bucket + + in tree_of_val max_depth obj ty + +end diff --git a/ocaml-binary-annot/toplevel/genprintval.mli b/ocaml-binary-annot/toplevel/genprintval.mli new file mode 100644 index 0000000000..898588b2dd --- /dev/null +++ b/ocaml-binary-annot/toplevel/genprintval.mli @@ -0,0 +1,52 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Jerome Vouillon, 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Printing of values *) + +open Types +open Format + +module type OBJ = + sig + type t + val obj : t -> 'a + val is_block : t -> bool + val tag : t -> int + val size : t -> int + val field : t -> int -> t + end + +module type EVALPATH = + sig + type value + val eval_path: Path.t -> value + exception Error + val same_value: value -> value -> bool + end + +module type S = + sig + type t + val install_printer : + Path.t -> Types.type_expr -> (formatter -> t -> unit) -> unit + val remove_printer : Path.t -> unit + val outval_of_untyped_exception : t -> Outcometree.out_value + val outval_of_value : + int -> int -> + (int -> t -> Types.type_expr -> Outcometree.out_value option) -> + Env.t -> t -> type_expr -> Outcometree.out_value + end + +module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) : + (S with type t = O.t) diff --git a/ocaml-binary-annot/toplevel/opttopdirs.ml b/ocaml-binary-annot/toplevel/opttopdirs.ml new file mode 100644 index 0000000000..b586bae1c8 --- /dev/null +++ b/ocaml-binary-annot/toplevel/opttopdirs.ml @@ -0,0 +1,189 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Toplevel directives *) + +open Format +open Misc +open Longident +open Path +open Types +open Opttoploop + +(* The standard output formatter *) +let std_out = std_formatter + +(* To quit *) + +let dir_quit () = exit 0 + +let _ = Hashtbl.add directive_table "quit" (Directive_none dir_quit) + +(* To add a directory to the load path *) + +let dir_directory s = + let d = expand_directory Config.standard_library s in + Config.load_path := d :: !Config.load_path + +let _ = Hashtbl.add directive_table "directory" (Directive_string dir_directory) +let _ = Hashtbl.add directive_table "show_dirs" + (Directive_none + (fun () -> + List.iter print_endline !Config.load_path + )) + +(* To change the current directory *) + +let dir_cd s = Sys.chdir s + +let _ = Hashtbl.add directive_table "cd" (Directive_string dir_cd) + +(* Load in-core a .cmxs file *) + +let load_file ppf name0 = + let name = + try Some (find_in_path !Config.load_path name0) + with Not_found -> None in + match name with + | None -> fprintf ppf "File not found: %s@." name0; false + | Some name -> + let fn,tmp = + if Filename.check_suffix name ".cmx" || Filename.check_suffix name ".cmxa" + then + let cmxs = Filename.temp_file "caml" ".cmxs" in + Asmlink.link_shared ppf [name] cmxs; + cmxs,true + else + name,false in + + let success = + (* The Dynlink interface does not allow us to distinguish between + a Dynlink.Error exceptions raised in the loaded modules + or a genuine error during dynlink... *) + try Dynlink.loadfile fn; true + with + | Dynlink.Error err -> + fprintf ppf "Error while loading %s: %s.@." + name (Dynlink.error_message err); + false + | exn -> + print_exception_outcome ppf exn; + false + in + if tmp then (try Sys.remove fn with Sys_error _ -> ()); + success + + +let dir_load ppf name = ignore (load_file ppf name) + +let _ = Hashtbl.add directive_table "load" (Directive_string (dir_load std_out)) + +(* Load commands from a file *) + +let dir_use ppf name = ignore(Opttoploop.use_file ppf name) + +let _ = Hashtbl.add directive_table "use" (Directive_string (dir_use std_out)) + +(* Install, remove a printer *) + +type 'a printer_type_new = Format.formatter -> 'a -> unit +type 'a printer_type_old = 'a -> unit + +let match_printer_type ppf desc typename = + let (printer_type, _) = + try + Env.lookup_type (Ldot(Lident "Topdirs", typename)) !toplevel_env + with Not_found -> + fprintf ppf "Cannot find type Topdirs.%s.@." typename; + raise Exit in + Ctype.init_def(Ident.current_time()); + Ctype.begin_def(); + let ty_arg = Ctype.newvar() in + Ctype.unify !toplevel_env + (Ctype.newconstr printer_type [ty_arg]) + (Ctype.instance desc.val_type); + Ctype.end_def(); + Ctype.generalize ty_arg; + ty_arg + +let find_printer_type ppf lid = + try + let (path, desc) = Env.lookup_value lid !toplevel_env in + let (ty_arg, is_old_style) = + try + (match_printer_type ppf desc "printer_type_new", false) + with Ctype.Unify _ -> + (match_printer_type ppf desc "printer_type_old", true) in + (ty_arg, path, is_old_style) + with + | Not_found -> + fprintf ppf "Unbound value %a.@." Printtyp.longident lid; + raise Exit + | Ctype.Unify _ -> + fprintf ppf "%a has a wrong type for a printing function.@." + Printtyp.longident lid; + raise Exit + +let dir_install_printer ppf lid = + try + let (ty_arg, path, is_old_style) = find_printer_type ppf lid in + let v = eval_path path in + let print_function = + if is_old_style then + (fun formatter repr -> Obj.obj v (Obj.obj repr)) + else + (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in + install_printer path ty_arg print_function + with Exit -> () + +let dir_remove_printer ppf lid = + try + let (ty_arg, path, is_old_style) = find_printer_type ppf lid in + begin try + remove_printer path + with Not_found -> + fprintf ppf "No printer named %a.@." Printtyp.longident lid + end + with Exit -> () + +let _ = Hashtbl.add directive_table "install_printer" + (Directive_ident (dir_install_printer std_out)) +let _ = Hashtbl.add directive_table "remove_printer" + (Directive_ident (dir_remove_printer std_out)) + +let parse_warnings ppf iserr s = + try Warnings.parse_options iserr s + with Arg.Bad err -> fprintf ppf "%s.@." err + +let _ = +(* Control the printing of values *) + + Hashtbl.add directive_table "print_depth" + (Directive_int(fun n -> max_printer_depth := n)); + Hashtbl.add directive_table "print_length" + (Directive_int(fun n -> max_printer_steps := n)); + +(* Set various compiler flags *) + + Hashtbl.add directive_table "labels" + (Directive_bool(fun b -> Clflags.classic := not b)); + + Hashtbl.add directive_table "principal" + (Directive_bool(fun b -> Clflags.principal := b)); + + Hashtbl.add directive_table "warnings" + (Directive_string (parse_warnings std_out false)); + + Hashtbl.add directive_table "warn_error" + (Directive_string (parse_warnings std_out true)) diff --git a/ocaml-binary-annot/toplevel/opttopdirs.mli b/ocaml-binary-annot/toplevel/opttopdirs.mli new file mode 100644 index 0000000000..800c6cf7bd --- /dev/null +++ b/ocaml-binary-annot/toplevel/opttopdirs.mli @@ -0,0 +1,31 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* The toplevel directives. *) + +open Format + +val dir_quit : unit -> unit +val dir_directory : string -> unit +val dir_cd : string -> unit +val dir_load : formatter -> string -> unit +val dir_use : formatter -> string -> unit +val dir_install_printer : formatter -> Longident.t -> unit +val dir_remove_printer : formatter -> Longident.t -> unit + +type 'a printer_type_new = Format.formatter -> 'a -> unit +type 'a printer_type_old = 'a -> unit + +(* For topmain.ml. Maybe shouldn't be there *) +val load_file : formatter -> string -> bool diff --git a/ocaml-binary-annot/toplevel/opttoploop.ml b/ocaml-binary-annot/toplevel/opttoploop.ml new file mode 100644 index 0000000000..ee6b5a0eab --- /dev/null +++ b/ocaml-binary-annot/toplevel/opttoploop.ml @@ -0,0 +1,446 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* The interactive toplevel loop *) + +open Path +open Lexing +open Format +open Config +open Misc +open Parsetree +open Types +open Typedtree +open Outcometree +open Lambda + +type res = Ok of Obj.t | Err of string +type evaluation_outcome = Result of Obj.t | Exception of exn + +external ndl_run_toplevel: string -> string -> res + = "caml_natdynlink_run_toplevel" +external ndl_loadsym: string -> Obj.t = "caml_natdynlink_loadsym" + +let global_symbol id = + let sym = Compilenv.symbol_for_global id in + try ndl_loadsym sym + with _ -> fatal_error ("Opttoploop.global_symbol " ^ (Ident.unique_name id)) + +let need_symbol sym = + try ignore (ndl_loadsym sym); false + with _ -> true + +let dll_run dll entry = + match (try Result (Obj.magic (ndl_run_toplevel dll entry)) with exn -> Exception exn) with + | Exception _ as r -> r + | Result r -> + match Obj.magic r with + | Ok x -> Result x + | Err s -> fatal_error ("Opttoploop.dll_run " ^ s) + + +type directive_fun = + | Directive_none of (unit -> unit) + | Directive_string of (string -> unit) + | Directive_int of (int -> unit) + | Directive_ident of (Longident.t -> unit) + | Directive_bool of (bool -> unit) + + +(* Return the value referred to by a path *) + +let toplevel_value id = + let (glb,pos) = Translmod.nat_toplevel_name id in + (Obj.magic (global_symbol glb)).(pos) + +let rec eval_path = function + | Pident id -> + if Ident.persistent id || Ident.global id + then global_symbol id + else toplevel_value id + | Pdot(p, s, pos) -> + Obj.field (eval_path p) pos + | Papply(p1, p2) -> + fatal_error "Toploop.eval_path" + +(* To print values *) + +module EvalPath = struct + type value = Obj.t + exception Error + let eval_path p = try eval_path p with _ -> raise Error + let same_value v1 v2 = (v1 == v2) +end + +module Printer = Genprintval.Make(Obj)(EvalPath) + +let max_printer_depth = ref 100 +let max_printer_steps = ref 300 + +let print_out_value = Oprint.out_value +let print_out_type = Oprint.out_type +let print_out_class_type = Oprint.out_class_type +let print_out_module_type = Oprint.out_module_type +let print_out_sig_item = Oprint.out_sig_item +let print_out_signature = Oprint.out_signature +let print_out_phrase = Oprint.out_phrase + +let print_untyped_exception ppf obj = + !print_out_value ppf (Printer.outval_of_untyped_exception obj) +let outval_of_value env obj ty = + Printer.outval_of_value !max_printer_steps !max_printer_depth + (fun _ _ _ -> None) env obj ty +let print_value env obj ppf ty = + !print_out_value ppf (outval_of_value env obj ty) + +let install_printer = Printer.install_printer +let remove_printer = Printer.remove_printer + +(* Hooks for parsing functions *) + +let parse_toplevel_phrase = ref Parse.toplevel_phrase +let parse_use_file = ref Parse.use_file +let print_location = Location.print_error (* FIXME change back to print *) +let print_error = Location.print_error +let print_warning = Location.print_warning +let input_name = Location.input_name + +(* Hooks for initialization *) + +let toplevel_startup_hook = ref (fun () -> ()) + +(* Load in-core and execute a lambda term *) + +let phrase_seqid = ref 0 +let phrase_name = ref "TOP" + +open Lambda + +let load_lambda ppf (size, lam) = + if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam; + let slam = Simplif.simplify_lambda lam in + if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam; + + let dll = + if !Clflags.keep_asm_file then !phrase_name ^ ext_dll + else Filename.temp_file ("caml" ^ !phrase_name) ext_dll + in + let fn = Filename.chop_extension dll in + Asmgen.compile_implementation ~toplevel:need_symbol fn ppf (size, lam); + Asmlink.call_linker_shared [fn ^ ext_obj] dll; + Sys.remove (fn ^ ext_obj); + + let dll = + if Filename.is_implicit dll + then Filename.concat (Sys.getcwd ()) dll + else dll in + let res = dll_run dll !phrase_name in + (try Sys.remove dll with Sys_error _ -> ()); + (* note: under windows, cannot remove a loaded dll + (should remember the handles, close them in at_exit, and then remove + files) *) + res + +(* Print the outcome of an evaluation *) + +let rec pr_item env = function + | Tsig_value(id, decl) :: rem -> + let tree = Printtyp.tree_of_value_description id decl in + let valopt = + match decl.val_kind with + | Val_prim _ -> None + | _ -> + let v = + outval_of_value env (toplevel_value id) + decl.val_type + in + Some v + in + Some (tree, valopt, rem) + | Tsig_type(id, _, _) :: rem when Btype.is_row_name (Ident.name id) -> + pr_item env rem + | Tsig_type(id, decl, rs) :: rem -> + let tree = Printtyp.tree_of_type_declaration id decl rs in + Some (tree, None, rem) + | Tsig_exception(id, decl) :: rem -> + let tree = Printtyp.tree_of_exception_declaration id decl in + Some (tree, None, rem) + | Tsig_module(id, mty, rs) :: rem -> + let tree = Printtyp.tree_of_module id mty rs in + Some (tree, None, rem) + | Tsig_modtype(id, decl) :: rem -> + let tree = Printtyp.tree_of_modtype_declaration id decl in + Some (tree, None, rem) + | Tsig_class(id, decl, rs) :: cltydecl :: tydecl1 :: tydecl2 :: rem -> + let tree = Printtyp.tree_of_class_declaration id decl rs in + Some (tree, None, rem) + | Tsig_cltype(id, decl, rs) :: tydecl1 :: tydecl2 :: rem -> + let tree = Printtyp.tree_of_cltype_declaration id decl rs in + Some (tree, None, rem) + | _ -> None + +let rec item_list env = function + | [] -> [] + | items -> + match pr_item env items with + | None -> [] + | Some (tree, valopt, items) -> (tree, valopt) :: item_list env items + +(* The current typing environment for the toplevel *) + +let toplevel_env = ref Env.empty + +(* Print an exception produced by an evaluation *) + +let print_out_exception ppf exn outv = + !print_out_phrase ppf (Ophr_exception (exn, outv)) + +let print_exception_outcome ppf exn = + if exn = Out_of_memory then Gc.full_major (); + let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in + print_out_exception ppf exn outv + +(* The table of toplevel directives. + Filled by functions from module topdirs. *) + +let directive_table = (Hashtbl.create 13 : (string, directive_fun) Hashtbl.t) + +(* Execute a toplevel phrase *) + +let execute_phrase print_outcome ppf phr = + match phr with + | Ptop_def sstr -> + let oldenv = !toplevel_env in + incr phrase_seqid; + phrase_name := Printf.sprintf "TOP%i" !phrase_seqid; + Compilenv.reset ?packname:None !phrase_name; + let _ = Unused_var.warn ppf sstr in + Typecore.reset_delayed_checks (); + let (str, sg, newenv) = Typemod.type_structure oldenv sstr Location.none + in + Typecore.force_delayed_checks (); + let res = Translmod.transl_store_phrases !phrase_name str in + Warnings.check_fatal (); + begin try + toplevel_env := newenv; + let res = load_lambda ppf res in + let out_phr = + match res with + | Result v -> + Compilenv.record_global_approx_toplevel (); + if print_outcome then + match str with + | [Tstr_eval exp] -> + let outv = outval_of_value newenv v exp.exp_type in + let ty = Printtyp.tree_of_type_scheme exp.exp_type in + Ophr_eval (outv, ty) + | [] -> Ophr_signature [] + | _ -> + Ophr_signature (item_list newenv + (Typemod.simplify_signature sg)) + + else Ophr_signature [] + | Exception exn -> + toplevel_env := oldenv; + if exn = Out_of_memory then Gc.full_major(); + let outv = + outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn + in + Ophr_exception (exn, outv) + in + !print_out_phrase ppf out_phr; + begin match out_phr with + | Ophr_eval (_, _) | Ophr_signature _ -> true + | Ophr_exception _ -> false + end + with x -> + toplevel_env := oldenv; raise x + end + | Ptop_dir(dir_name, dir_arg) -> + try + match (Hashtbl.find directive_table dir_name, dir_arg) with + | (Directive_none f, Pdir_none) -> f (); true + | (Directive_string f, Pdir_string s) -> f s; true + | (Directive_int f, Pdir_int n) -> f n; true + | (Directive_ident f, Pdir_ident lid) -> f lid; true + | (Directive_bool f, Pdir_bool b) -> f b; true + | (_, _) -> + fprintf ppf "Wrong type of argument for directive `%s'.@." dir_name; + false + with Not_found -> + fprintf ppf "Unknown directive `%s'.@." dir_name; + false + +(* Temporary assignment to a reference *) + +let protect r newval body = + let oldval = !r in + try + r := newval; + let res = body() in + r := oldval; + res + with x -> + r := oldval; + raise x + +(* Read and execute commands from a file *) + +let use_print_results = ref true + +let use_file ppf name = + try + let filename = find_in_path !Config.load_path name in + let ic = open_in_bin filename in + let lb = Lexing.from_channel ic in + Location.init lb filename; + (* Skip initial #! line if any *) + Lexer.skip_sharp_bang lb; + let success = + protect Location.input_name filename (fun () -> + try + List.iter + (fun ph -> + if !Clflags.dump_parsetree then Printast.top_phrase ppf ph; + if not (execute_phrase !use_print_results ppf ph) then raise Exit) + (!parse_use_file lb); + true + with + | Exit -> false + | Sys.Break -> fprintf ppf "Interrupted.@."; false + | x -> Opterrors.report_error ppf x; false) in + close_in ic; + success + with Not_found -> fprintf ppf "Cannot find file %s.@." name; false + +let use_silently ppf name = + protect use_print_results false (fun () -> use_file ppf name) + +(* Reading function for interactive use *) + +let first_line = ref true +let got_eof = ref false;; + +let read_input_default prompt buffer len = + output_string Pervasives.stdout prompt; flush Pervasives.stdout; + let i = ref 0 in + try + while true do + if !i >= len then raise Exit; + let c = input_char stdin in + buffer.[!i] <- c; + incr i; + if c = '\n' then raise Exit; + done; + (!i, false) + with + | End_of_file -> + (!i, true) + | Exit -> + (!i, false) + +let read_interactive_input = ref read_input_default + +let refill_lexbuf buffer len = + if !got_eof then (got_eof := false; 0) else begin + let prompt = + if !Clflags.noprompt then "" + else if !first_line then "# " + else if Lexer.in_comment () then "* " + else " " + in + first_line := false; + let (len, eof) = !read_interactive_input prompt buffer len in + if eof then begin + Location.echo_eof (); + if len > 0 then got_eof := true; + len + end else + len + end + +(* Toplevel initialization. Performed here instead of at the + beginning of loop() so that user code linked in with ocamlmktop + can call directives from Topdirs. *) + +let _ = + Sys.interactive := true; + Dynlink.init (); + Optcompile.init_path(); + Clflags.dlcode := true; + () + +let load_ocamlinit ppf = + match !Clflags.init_file with + | Some f -> if Sys.file_exists f then ignore (use_silently ppf f) + else fprintf ppf "Init file not found: \"%s\".@." f + | None -> + if Sys.file_exists ".ocamlinit" then ignore (use_silently ppf ".ocamlinit") + else try + let home_init = Filename.concat (Sys.getenv "HOME") ".ocamlinit" in + if Sys.file_exists home_init then ignore (use_silently ppf home_init) + with Not_found -> () +;; + +let set_paths () = + (* Add whatever -I options have been specified on the command line, + but keep the directories that user code linked in with ocamlmktop + may have added to load_path. *) + load_path := !load_path @ [Filename.concat Config.standard_library "camlp4"]; + load_path := "" :: (List.rev !Clflags.include_dirs @ !load_path); + () + +let initialize_toplevel_env () = + toplevel_env := Optcompile.initial_env() + +(* The interactive loop *) + +exception PPerror + +let loop ppf = + fprintf ppf " Objective Caml version %s - native toplevel@.@." Config.version; + initialize_toplevel_env (); + let lb = Lexing.from_function refill_lexbuf in + Location.input_name := ""; + Location.input_lexbuf := Some lb; + Sys.catch_break true; + load_ocamlinit ppf; + while true do + let snap = Btype.snapshot () in + try + Lexing.flush_input lb; + Location.reset(); + first_line := true; + let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in + if !Clflags.dump_parsetree then Printast.top_phrase ppf phr; + ignore(execute_phrase true ppf phr) + with + | End_of_file -> exit 0 + | Sys.Break -> fprintf ppf "Interrupted.@."; Btype.backtrack snap + | PPerror -> () + | x -> Opterrors.report_error ppf x; Btype.backtrack snap + done + +(* Execute a script *) + +let run_script ppf name args = + let len = Array.length args in + if Array.length Sys.argv < len then invalid_arg "Toploop.run_script"; + Array.blit args 0 Sys.argv 0 len; + Obj.truncate (Obj.repr Sys.argv) len; + Arg.current := 0; + Optcompile.init_path(); + toplevel_env := Optcompile.initial_env(); + Sys.interactive := false; + use_silently ppf name diff --git a/ocaml-binary-annot/toplevel/opttoploop.mli b/ocaml-binary-annot/toplevel/opttoploop.mli new file mode 100644 index 0000000000..78e45f0bab --- /dev/null +++ b/ocaml-binary-annot/toplevel/opttoploop.mli @@ -0,0 +1,102 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Format + +(* Set the load paths, before running anything *) + +val set_paths : unit -> unit + +(* The interactive toplevel loop *) + +val loop : formatter -> unit + +(* Read and execute a script from the given file *) + +val run_script : formatter -> string -> string array -> bool + (* true if successful, false if error *) + +(* Interface with toplevel directives *) + +type directive_fun = + | Directive_none of (unit -> unit) + | Directive_string of (string -> unit) + | Directive_int of (int -> unit) + | Directive_ident of (Longident.t -> unit) + | Directive_bool of (bool -> unit) + +val directive_table : (string, directive_fun) Hashtbl.t + (* Table of known directives, with their execution function *) +val toplevel_env : Env.t ref + (* Typing environment for the toplevel *) +val initialize_toplevel_env : unit -> unit + (* Initialize the typing environment for the toplevel *) +val print_exception_outcome : formatter -> exn -> unit + (* Print an exception resulting from the evaluation of user code. *) +val execute_phrase : bool -> formatter -> Parsetree.toplevel_phrase -> bool + (* Execute the given toplevel phrase. Return [true] if the + phrase executed with no errors and [false] otherwise. + First bool says whether the values and types of the results + should be printed. Uncaught exceptions are always printed. *) +val use_file : formatter -> string -> bool +val use_silently : formatter -> string -> bool + (* Read and execute commands from a file. + [use_file] prints the types and values of the results. + [use_silently] does not print them. *) +val eval_path: Path.t -> Obj.t + (* Return the toplevel object referred to by the given path *) + +(* Printing of values *) + +val print_value: Env.t -> Obj.t -> formatter -> Types.type_expr -> unit +val print_untyped_exception: formatter -> Obj.t -> unit + +val install_printer : + Path.t -> Types.type_expr -> (formatter -> Obj.t -> unit) -> unit +val remove_printer : Path.t -> unit + +val max_printer_depth: int ref +val max_printer_steps: int ref + +(* Hooks for external parsers and printers *) + +val parse_toplevel_phrase : (Lexing.lexbuf -> Parsetree.toplevel_phrase) ref +val parse_use_file : (Lexing.lexbuf -> Parsetree.toplevel_phrase list) ref +val print_location : formatter -> Location.t -> unit +val print_error : formatter -> Location.t -> unit +val print_warning : Location.t -> formatter -> Warnings.t -> unit +val input_name : string ref + +val print_out_value : + (formatter -> Outcometree.out_value -> unit) ref +val print_out_type : + (formatter -> Outcometree.out_type -> unit) ref +val print_out_class_type : + (formatter -> Outcometree.out_class_type -> unit) ref +val print_out_module_type : + (formatter -> Outcometree.out_module_type -> unit) ref +val print_out_sig_item : + (formatter -> Outcometree.out_sig_item -> unit) ref +val print_out_signature : + (formatter -> Outcometree.out_sig_item list -> unit) ref +val print_out_phrase : + (formatter -> Outcometree.out_phrase -> unit) ref + +(* Hooks for external line editor *) + +val read_interactive_input : (string -> string -> int -> int * bool) ref + +(* Hooks for initialization *) + +val toplevel_startup_hook : (unit -> unit) ref diff --git a/ocaml-binary-annot/toplevel/opttopmain.ml b/ocaml-binary-annot/toplevel/opttopmain.ml new file mode 100644 index 0000000000..bd27abb760 --- /dev/null +++ b/ocaml-binary-annot/toplevel/opttopmain.ml @@ -0,0 +1,111 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Clflags + +let usage = "Usage: ocamlnat <options> <object-files> [script-file]\noptions are:" + +let preload_objects = ref [] + +let prepare ppf = + Opttoploop.set_paths (); + try + let res = + List.for_all (Opttopdirs.load_file ppf) (List.rev !preload_objects) + in + !Opttoploop.toplevel_startup_hook (); + res + with x -> + try Opterrors.report_error ppf x; false + with x -> + Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x); + false + +let file_argument name = + let ppf = Format.err_formatter in + if Filename.check_suffix name ".cmxs" + || Filename.check_suffix name ".cmx" + || Filename.check_suffix name ".cmxa" + then preload_objects := name :: !preload_objects + else + begin + let newargs = Array.sub Sys.argv !Arg.current + (Array.length Sys.argv - !Arg.current) + in + if prepare ppf && Opttoploop.run_script ppf name newargs + then exit 0 + else exit 2 + end + +let print_version () = + Printf.printf "The Objective Caml toplevel, version %s\n" Sys.ocaml_version; + exit 0; +;; + +let print_version_num () = + Printf.printf "%s\n" Sys.ocaml_version; + exit 0; +;; + +module Options = Main_args.Make_opttop_options (struct + let set r () = r := true + let clear r () = r := false + + let _compact = clear optimize_for_speed + let _I dir = + let dir = Misc.expand_directory Config.standard_library dir in + include_dirs := dir :: !include_dirs + let _init s = init_file := Some s + let _inline n = inline_threshold := n * 8 + let _labels = clear classic + let _no_app_funct = clear applicative_functors + let _noassert = set noassert + let _nolabels = set classic + let _noprompt = set noprompt + let _nostdlib = set no_std_include + let _principal = set principal + let _rectypes = set recursive_types + let _strict_sequence = set strict_sequence + let _S = set keep_asm_file + let _unsafe = set fast + let _version () = print_version () + let _vnum () = print_version_num () + let _w s = Warnings.parse_options false s + let _warn_error s = Warnings.parse_options true s + let _warn_help = Warnings.help_warnings + + let _dparsetree = set dump_parsetree + let _drawlambda = set dump_rawlambda + let _dlambda = set dump_lambda + let _dcmm = set dump_cmm + let _dsel = set dump_selection + let _dcombine = set dump_combine + let _dlive () = dump_live := true; Printmach.print_live := true + let _dspill = set dump_spill + let _dsplit = set dump_split + let _dinterf = set dump_interf + let _dprefer = set dump_prefer + let _dalloc = set dump_regalloc + let _dreload = set dump_reload + let _dscheduling = set dump_scheduling + let _dlinear = set dump_linear + let _dstartup = set keep_startup_file + + let anonymous = file_argument +end);; + +let main () = + Arg.parse Options.list file_argument usage; + if not (prepare Format.err_formatter) then exit 2; + Opttoploop.loop Format.std_formatter diff --git a/ocaml-binary-annot/toplevel/opttopmain.mli b/ocaml-binary-annot/toplevel/opttopmain.mli new file mode 100644 index 0000000000..197f88bbc6 --- /dev/null +++ b/ocaml-binary-annot/toplevel/opttopmain.mli @@ -0,0 +1,17 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Start the [ocaml] toplevel loop *) + +val main: unit -> unit diff --git a/ocaml-binary-annot/toplevel/opttopstart.ml b/ocaml-binary-annot/toplevel/opttopstart.ml new file mode 100644 index 0000000000..3e3fe58baf --- /dev/null +++ b/ocaml-binary-annot/toplevel/opttopstart.ml @@ -0,0 +1,15 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +let _ = Opttopmain.main() diff --git a/ocaml-binary-annot/toplevel/topdirs.ml b/ocaml-binary-annot/toplevel/topdirs.ml new file mode 100644 index 0000000000..6516a38770 --- /dev/null +++ b/ocaml-binary-annot/toplevel/topdirs.ml @@ -0,0 +1,304 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Toplevel directives *) + +open Format +open Misc +open Longident +open Path +open Types +open Cmo_format +open Trace +open Toploop + +(* The standard output formatter *) +let std_out = std_formatter + +(* To quit *) + +let dir_quit () = exit 0 + +let _ = Hashtbl.add directive_table "quit" (Directive_none dir_quit) + +(* To add a directory to the load path *) + +let dir_directory s = + let d = expand_directory Config.standard_library s in + Config.load_path := d :: !Config.load_path; + Dll.add_path [d] + +let _ = Hashtbl.add directive_table "directory" (Directive_string dir_directory) + +(* To change the current directory *) + +let dir_cd s = Sys.chdir s + +let _ = Hashtbl.add directive_table "cd" (Directive_string dir_cd) + +(* Load in-core a .cmo file *) + +exception Load_failed + +let check_consistency ppf filename cu = + try + List.iter + (fun (name, crc) -> Consistbl.check Env.crc_units name crc filename) + cu.cu_imports + with Consistbl.Inconsistency(name, user, auth) -> + fprintf ppf "@[<hv 0>The files %s@ and %s@ \ + disagree over interface %s@]@." + user auth name; + raise Load_failed + +let load_compunit ic filename ppf compunit = + check_consistency ppf filename compunit; + seek_in ic compunit.cu_pos; + let code_size = compunit.cu_codesize + 8 in + let code = Meta.static_alloc code_size in + unsafe_really_input ic code 0 compunit.cu_codesize; + String.unsafe_set code compunit.cu_codesize (Char.chr Opcodes.opRETURN); + String.unsafe_blit "\000\000\000\001\000\000\000" 0 + code (compunit.cu_codesize + 1) 7; + let initial_symtable = Symtable.current_state() in + Symtable.patch_object code compunit.cu_reloc; + Symtable.update_global_table(); + begin try + may_trace := true; + ignore((Meta.reify_bytecode code code_size) ()); + may_trace := false; + with exn -> + may_trace := false; + Symtable.restore_state initial_symtable; + print_exception_outcome ppf exn; + raise Load_failed + end + +let load_file ppf name = + try + let filename = find_in_path !Config.load_path name in + let ic = open_in_bin filename in + let buffer = String.create (String.length Config.cmo_magic_number) in + really_input ic buffer 0 (String.length Config.cmo_magic_number); + let success = try + if buffer = Config.cmo_magic_number then begin + let compunit_pos = input_binary_int ic in (* Go to descriptor *) + seek_in ic compunit_pos; + load_compunit ic filename ppf (input_value ic : compilation_unit); + true + end else + if buffer = Config.cma_magic_number then begin + let toc_pos = input_binary_int ic in (* Go to table of contents *) + seek_in ic toc_pos; + let lib = (input_value ic : library) in + List.iter + (fun dllib -> + let name = Dll.extract_dll_name dllib in + try Dll.open_dlls Dll.For_execution [name] + with Failure reason -> + fprintf ppf + "Cannot load required shared library %s.@.Reason: %s.@." + name reason; + raise Load_failed) + lib.lib_dllibs; + List.iter (load_compunit ic filename ppf) lib.lib_units; + true + end else begin + fprintf ppf "File %s is not a bytecode object file.@." name; + false + end + with Load_failed -> false in + close_in ic; + success + with Not_found -> fprintf ppf "Cannot find file %s.@." name; false + +let dir_load ppf name = ignore (load_file ppf name) + +let _ = Hashtbl.add directive_table "load" (Directive_string (dir_load std_out)) + +(* Load commands from a file *) + +let dir_use ppf name = ignore(Toploop.use_file ppf name) + +let _ = Hashtbl.add directive_table "use" (Directive_string (dir_use std_out)) + +(* Install, remove a printer *) + +type 'a printer_type_new = Format.formatter -> 'a -> unit +type 'a printer_type_old = 'a -> unit + +let match_printer_type ppf desc typename = + let (printer_type, _) = + try + Env.lookup_type (Ldot(Lident "Topdirs", typename)) !toplevel_env + with Not_found -> + fprintf ppf "Cannot find type Topdirs.%s.@." typename; + raise Exit in + Ctype.init_def(Ident.current_time()); + Ctype.begin_def(); + let ty_arg = Ctype.newvar() in + Ctype.unify !toplevel_env + (Ctype.newconstr printer_type [ty_arg]) + (Ctype.instance desc.val_type); + Ctype.end_def(); + Ctype.generalize ty_arg; + ty_arg + +let find_printer_type ppf lid = + try + let (path, desc) = Env.lookup_value lid !toplevel_env in + let (ty_arg, is_old_style) = + try + (match_printer_type ppf desc "printer_type_new", false) + with Ctype.Unify _ -> + (match_printer_type ppf desc "printer_type_old", true) in + (ty_arg, path, is_old_style) + with + | Not_found -> + fprintf ppf "Unbound value %a.@." Printtyp.longident lid; + raise Exit + | Ctype.Unify _ -> + fprintf ppf "%a has a wrong type for a printing function.@." + Printtyp.longident lid; + raise Exit + +let dir_install_printer ppf lid = + try + let (ty_arg, path, is_old_style) = find_printer_type ppf lid in + let v = eval_path path in + let print_function = + if is_old_style then + (fun formatter repr -> Obj.obj v (Obj.obj repr)) + else + (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in + install_printer path ty_arg print_function + with Exit -> () + +let dir_remove_printer ppf lid = + try + let (ty_arg, path, is_old_style) = find_printer_type ppf lid in + begin try + remove_printer path + with Not_found -> + fprintf ppf "No printer named %a.@." Printtyp.longident lid + end + with Exit -> () + +let _ = Hashtbl.add directive_table "install_printer" + (Directive_ident (dir_install_printer std_out)) +let _ = Hashtbl.add directive_table "remove_printer" + (Directive_ident (dir_remove_printer std_out)) + +(* The trace *) + +external current_environment: unit -> Obj.t = "caml_get_current_environment" + +let tracing_function_ptr = + get_code_pointer + (Obj.repr (fun arg -> Trace.print_trace (current_environment()) arg)) + +let dir_trace ppf lid = + try + let (path, desc) = Env.lookup_value lid !toplevel_env in + (* Check if this is a primitive *) + match desc.val_kind with + | Val_prim p -> + fprintf ppf "%a is an external function and cannot be traced.@." + Printtyp.longident lid + | _ -> + let clos = eval_path path in + (* Nothing to do if it's not a closure *) + if Obj.is_block clos + && (Obj.tag clos = Obj.closure_tag || Obj.tag clos = Obj.infix_tag) + then begin + match is_traced clos with + | Some opath -> + fprintf ppf "%a is already traced (under the name %a).@." + Printtyp.path path + Printtyp.path opath + | None -> + (* Instrument the old closure *) + traced_functions := + { path = path; + closure = clos; + actual_code = get_code_pointer clos; + instrumented_fun = + instrument_closure !toplevel_env lid ppf desc.val_type } + :: !traced_functions; + (* Redirect the code field of the closure to point + to the instrumentation function *) + set_code_pointer clos tracing_function_ptr; + fprintf ppf "%a is now traced.@." Printtyp.longident lid + end else fprintf ppf "%a is not a function.@." Printtyp.longident lid + with + | Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid + +let dir_untrace ppf lid = + try + let (path, desc) = Env.lookup_value lid !toplevel_env in + let rec remove = function + | [] -> + fprintf ppf "%a was not traced.@." Printtyp.longident lid; + [] + | f :: rem -> + if Path.same f.path path then begin + set_code_pointer f.closure f.actual_code; + fprintf ppf "%a is no longer traced.@." Printtyp.longident lid; + rem + end else f :: remove rem in + traced_functions := remove !traced_functions + with + | Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid + +let dir_untrace_all ppf () = + List.iter + (fun f -> + set_code_pointer f.closure f.actual_code; + fprintf ppf "%a is no longer traced.@." Printtyp.path f.path) + !traced_functions; + traced_functions := [] + +let parse_warnings ppf iserr s = + try Warnings.parse_options iserr s + with Arg.Bad err -> fprintf ppf "%s.@." err + +let _ = + Hashtbl.add directive_table "trace" (Directive_ident (dir_trace std_out)); + Hashtbl.add directive_table "untrace" (Directive_ident (dir_untrace std_out)); + Hashtbl.add directive_table + "untrace_all" (Directive_none (dir_untrace_all std_out)); + +(* Control the printing of values *) + + Hashtbl.add directive_table "print_depth" + (Directive_int(fun n -> max_printer_depth := n)); + Hashtbl.add directive_table "print_length" + (Directive_int(fun n -> max_printer_steps := n)); + +(* Set various compiler flags *) + + Hashtbl.add directive_table "labels" + (Directive_bool(fun b -> Clflags.classic := not b)); + + Hashtbl.add directive_table "principal" + (Directive_bool(fun b -> Clflags.principal := b)); + + Hashtbl.add directive_table "rectypes" + (Directive_none(fun () -> Clflags.recursive_types := true)); + + Hashtbl.add directive_table "warnings" + (Directive_string (parse_warnings std_out false)); + + Hashtbl.add directive_table "warn_error" + (Directive_string (parse_warnings std_out true)) diff --git a/ocaml-binary-annot/toplevel/topdirs.mli b/ocaml-binary-annot/toplevel/topdirs.mli new file mode 100644 index 0000000000..36af2211ba --- /dev/null +++ b/ocaml-binary-annot/toplevel/topdirs.mli @@ -0,0 +1,34 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* The toplevel directives. *) + +open Format + +val dir_quit : unit -> unit +val dir_directory : string -> unit +val dir_cd : string -> unit +val dir_load : formatter -> string -> unit +val dir_use : formatter -> string -> unit +val dir_install_printer : formatter -> Longident.t -> unit +val dir_remove_printer : formatter -> Longident.t -> unit +val dir_trace : formatter -> Longident.t -> unit +val dir_untrace : formatter -> Longident.t -> unit +val dir_untrace_all : formatter -> unit -> unit + +type 'a printer_type_new = Format.formatter -> 'a -> unit +type 'a printer_type_old = 'a -> unit + +(* For topmain.ml. Maybe shouldn't be there *) +val load_file : formatter -> string -> bool diff --git a/ocaml-binary-annot/toplevel/toplevellib.mllib b/ocaml-binary-annot/toplevel/toplevellib.mllib new file mode 100644 index 0000000000..a5e8b03f24 --- /dev/null +++ b/ocaml-binary-annot/toplevel/toplevellib.mllib @@ -0,0 +1,19 @@ +Myocamlbuild_config +Misc Tbl Config Clflags Terminfo Ccomp Warnings Consistbl + +Linenum Location Longident Syntaxerr Parser +Lexer Parse Printast + +Unused_var Ident Path Primitive Types +Btype Oprint Subst Predef Datarepr Env +Typedtree Ctype Printtyp Includeclass Mtype Includecore +Includemod Parmatch Typetexp Stypes Typecore +Typedecl Typeclass Typemod + +Lambda Printlambda Typeopt Switch Matching Translobj Translcore +Translclass Translmod Simplif Runtimedef + +Meta Instruct Bytegen Printinstr Opcodes Emitcode +Bytesections Dll Symtable Bytelink Bytelibrarian Bytepackager + +Pparse Errors Compile Main_args Genprintval Toploop Trace Topdirs Topmain diff --git a/ocaml-binary-annot/toplevel/toploop.ml b/ocaml-binary-annot/toplevel/toploop.ml new file mode 100644 index 0000000000..250a27b52c --- /dev/null +++ b/ocaml-binary-annot/toplevel/toploop.ml @@ -0,0 +1,437 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* The interactive toplevel loop *) + +open Path +open Lexing +open Format +open Config +open Misc +open Parsetree +open Types +open Typedtree +open Outcometree + +type directive_fun = + | Directive_none of (unit -> unit) + | Directive_string of (string -> unit) + | Directive_int of (int -> unit) + | Directive_ident of (Longident.t -> unit) + | Directive_bool of (bool -> unit) + +(* The table of toplevel value bindings and its accessors *) + +let toplevel_value_bindings = + (Hashtbl.create 37 : (string, Obj.t) Hashtbl.t) + +let getvalue name = + try + Hashtbl.find toplevel_value_bindings name + with Not_found -> + fatal_error (name ^ " unbound at toplevel") + +let setvalue name v = + Hashtbl.replace toplevel_value_bindings name v + +(* Return the value referred to by a path *) + +let rec eval_path = function + | Pident id -> + if Ident.persistent id || Ident.global id then + Symtable.get_global_value id + else begin + let name = Translmod.toplevel_name id in + try + Hashtbl.find toplevel_value_bindings name + with Not_found -> + raise (Symtable.Error(Symtable.Undefined_global name)) + end + | Pdot(p, s, pos) -> + Obj.field (eval_path p) pos + | Papply(p1, p2) -> + fatal_error "Toploop.eval_path" + +(* To print values *) + +module EvalPath = struct + type value = Obj.t + exception Error + let eval_path p = try eval_path p with Symtable.Error _ -> raise Error + let same_value v1 v2 = (v1 == v2) +end + +module Printer = Genprintval.Make(Obj)(EvalPath) + +let max_printer_depth = ref 100 +let max_printer_steps = ref 300 + +let print_out_value = Oprint.out_value +let print_out_type = Oprint.out_type +let print_out_class_type = Oprint.out_class_type +let print_out_module_type = Oprint.out_module_type +let print_out_sig_item = Oprint.out_sig_item +let print_out_signature = Oprint.out_signature +let print_out_phrase = Oprint.out_phrase + +let print_untyped_exception ppf obj = + !print_out_value ppf (Printer.outval_of_untyped_exception obj) +let outval_of_value env obj ty = + Printer.outval_of_value !max_printer_steps !max_printer_depth + (fun _ _ _ -> None) env obj ty +let print_value env obj ppf ty = + !print_out_value ppf (outval_of_value env obj ty) + +let install_printer = Printer.install_printer +let remove_printer = Printer.remove_printer + +(* Hooks for parsing functions *) + +let parse_toplevel_phrase = ref Parse.toplevel_phrase +let parse_use_file = ref Parse.use_file +let print_location = Location.print_error (* FIXME change back to print *) +let print_error = Location.print_error +let print_warning = Location.print_warning +let input_name = Location.input_name + +(* Hooks for initialization *) + +let toplevel_startup_hook = ref (fun () -> ()) + +(* Load in-core and execute a lambda term *) + +let may_trace = ref false (* Global lock on tracing *) +type evaluation_outcome = Result of Obj.t | Exception of exn + +let load_lambda ppf lam = + if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam; + let slam = Simplif.simplify_lambda lam in + if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam; + let (init_code, fun_code) = Bytegen.compile_phrase slam in + if !Clflags.dump_instr then + fprintf ppf "%a%a@." + Printinstr.instrlist init_code + Printinstr.instrlist fun_code; + let (code, code_size, reloc) = Emitcode.to_memory init_code fun_code in + let can_free = (fun_code = []) in + let initial_symtable = Symtable.current_state() in + Symtable.patch_object code reloc; + Symtable.check_global_initialized reloc; + Symtable.update_global_table(); + try + may_trace := true; + let retval = (Meta.reify_bytecode code code_size) () in + may_trace := false; + if can_free then begin + Meta.static_release_bytecode code code_size; + Meta.static_free code; + end; + Result retval + with x -> + may_trace := false; + if can_free then begin + Meta.static_release_bytecode code code_size; + Meta.static_free code; + end; + Symtable.restore_state initial_symtable; + Exception x + +(* Print the outcome of an evaluation *) + +let rec pr_item env = function + | Tsig_value(id, decl) :: rem -> + let tree = Printtyp.tree_of_value_description id decl in + let valopt = + match decl.val_kind with + | Val_prim _ -> None + | _ -> + let v = + outval_of_value env (getvalue (Translmod.toplevel_name id)) + decl.val_type + in + Some v + in + Some (tree, valopt, rem) + | Tsig_type(id, _, _) :: rem when Btype.is_row_name (Ident.name id) -> + pr_item env rem + | Tsig_type(id, decl, rs) :: rem -> + let tree = Printtyp.tree_of_type_declaration id decl rs in + Some (tree, None, rem) + | Tsig_exception(id, decl) :: rem -> + let tree = Printtyp.tree_of_exception_declaration id decl in + Some (tree, None, rem) + | Tsig_module(id, mty, rs) :: rem -> + let tree = Printtyp.tree_of_module id mty rs in + Some (tree, None, rem) + | Tsig_modtype(id, decl) :: rem -> + let tree = Printtyp.tree_of_modtype_declaration id decl in + Some (tree, None, rem) + | Tsig_class(id, decl, rs) :: cltydecl :: tydecl1 :: tydecl2 :: rem -> + let tree = Printtyp.tree_of_class_declaration id decl rs in + Some (tree, None, rem) + | Tsig_cltype(id, decl, rs) :: tydecl1 :: tydecl2 :: rem -> + let tree = Printtyp.tree_of_cltype_declaration id decl rs in + Some (tree, None, rem) + | _ -> None + +let rec item_list env = function + | [] -> [] + | items -> + match pr_item env items with + | None -> [] + | Some (tree, valopt, items) -> (tree, valopt) :: item_list env items + +(* The current typing environment for the toplevel *) + +let toplevel_env = ref Env.empty + +(* Print an exception produced by an evaluation *) + +let print_out_exception ppf exn outv = + !print_out_phrase ppf (Ophr_exception (exn, outv)) + +let print_exception_outcome ppf exn = + if exn = Out_of_memory then Gc.full_major (); + let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in + print_out_exception ppf exn outv + +(* The table of toplevel directives. + Filled by functions from module topdirs. *) + +let directive_table = (Hashtbl.create 13 : (string, directive_fun) Hashtbl.t) + +(* Execute a toplevel phrase *) + +let execute_phrase print_outcome ppf phr = + match phr with + | Ptop_def sstr -> + let oldenv = !toplevel_env in + let _ = Unused_var.warn ppf sstr in + Typecore.reset_delayed_checks (); + let (str, sg, newenv) = Typemod.type_structure oldenv sstr Location.none + in + Typecore.force_delayed_checks (); + let lam = Translmod.transl_toplevel_definition str in + Warnings.check_fatal (); + begin try + toplevel_env := newenv; + let res = load_lambda ppf lam in + let out_phr = + match res with + | Result v -> + if print_outcome then + match str with + | [Tstr_eval exp] -> + let outv = outval_of_value newenv v exp.exp_type in + let ty = Printtyp.tree_of_type_scheme exp.exp_type in + Ophr_eval (outv, ty) + | [] -> Ophr_signature [] + | _ -> Ophr_signature (item_list newenv + (Typemod.simplify_signature sg)) + else Ophr_signature [] + | Exception exn -> + toplevel_env := oldenv; + if exn = Out_of_memory then Gc.full_major(); + let outv = + outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn + in + Ophr_exception (exn, outv) + in + !print_out_phrase ppf out_phr; + begin match out_phr with + | Ophr_eval (_, _) | Ophr_signature _ -> true + | Ophr_exception _ -> false + end + with x -> + toplevel_env := oldenv; raise x + end + | Ptop_dir(dir_name, dir_arg) -> + try + match (Hashtbl.find directive_table dir_name, dir_arg) with + | (Directive_none f, Pdir_none) -> f (); true + | (Directive_string f, Pdir_string s) -> f s; true + | (Directive_int f, Pdir_int n) -> f n; true + | (Directive_ident f, Pdir_ident lid) -> f lid; true + | (Directive_bool f, Pdir_bool b) -> f b; true + | (_, _) -> + fprintf ppf "Wrong type of argument for directive `%s'.@." dir_name; + false + with Not_found -> + fprintf ppf "Unknown directive `%s'.@." dir_name; + false + +(* Temporary assignment to a reference *) + +let protect r newval body = + let oldval = !r in + try + r := newval; + let res = body() in + r := oldval; + res + with x -> + r := oldval; + raise x + +(* Read and execute commands from a file *) + +let use_print_results = ref true + +let use_file ppf name = + try + let filename = find_in_path !Config.load_path name in + let ic = open_in_bin filename in + let lb = Lexing.from_channel ic in + Location.init lb filename; + (* Skip initial #! line if any *) + Lexer.skip_sharp_bang lb; + let success = + protect Location.input_name filename (fun () -> + try + List.iter + (fun ph -> + if !Clflags.dump_parsetree then Printast.top_phrase ppf ph; + if not (execute_phrase !use_print_results ppf ph) then raise Exit) + (!parse_use_file lb); + true + with + | Exit -> false + | Sys.Break -> fprintf ppf "Interrupted.@."; false + | x -> Errors.report_error ppf x; false) in + close_in ic; + success + with Not_found -> fprintf ppf "Cannot find file %s.@." name; false + +let use_silently ppf name = + protect use_print_results false (fun () -> use_file ppf name) + +(* Reading function for interactive use *) + +let first_line = ref true +let got_eof = ref false;; + +let read_input_default prompt buffer len = + output_string Pervasives.stdout prompt; flush Pervasives.stdout; + let i = ref 0 in + try + while true do + if !i >= len then raise Exit; + let c = input_char Pervasives.stdin in + buffer.[!i] <- c; + incr i; + if c = '\n' then raise Exit; + done; + (!i, false) + with + | End_of_file -> + (!i, true) + | Exit -> + (!i, false) + +let read_interactive_input = ref read_input_default + +let refill_lexbuf buffer len = + if !got_eof then (got_eof := false; 0) else begin + let prompt = + if !Clflags.noprompt then "" + else if !first_line then "# " + else if Lexer.in_comment () then "* " + else " " + in + first_line := false; + let (len, eof) = !read_interactive_input prompt buffer len in + if eof then begin + Location.echo_eof (); + if len > 0 then got_eof := true; + len + end else + len + end + +(* Toplevel initialization. Performed here instead of at the + beginning of loop() so that user code linked in with ocamlmktop + can call directives from Topdirs. *) + +let _ = + Sys.interactive := true; + let crc_intfs = Symtable.init_toplevel() in + Compile.init_path(); + List.iter + (fun (name, crc) -> + Consistbl.set Env.crc_units name crc Sys.executable_name) + crc_intfs + +let load_ocamlinit ppf = + match !Clflags.init_file with + | Some f -> if Sys.file_exists f then ignore (use_silently ppf f) + else fprintf ppf "Init file not found: \"%s\".@." f + | None -> + if Sys.file_exists ".ocamlinit" then ignore (use_silently ppf ".ocamlinit") + else try + let home_init = Filename.concat (Sys.getenv "HOME") ".ocamlinit" in + if Sys.file_exists home_init then ignore (use_silently ppf home_init) + with Not_found -> () +;; + +let set_paths () = + (* Add whatever -I options have been specified on the command line, + but keep the directories that user code linked in with ocamlmktop + may have added to load_path. *) + load_path := !load_path @ [Filename.concat Config.standard_library "camlp4"]; + load_path := "" :: (List.rev !Clflags.include_dirs @ !load_path); + Dll.add_path !load_path + +let initialize_toplevel_env () = + toplevel_env := Compile.initial_env() + +(* The interactive loop *) + +exception PPerror + +let loop ppf = + fprintf ppf " Objective Caml version %s@.@." Config.version; + initialize_toplevel_env (); + let lb = Lexing.from_function refill_lexbuf in + Location.input_name := ""; + Location.input_lexbuf := Some lb; + Sys.catch_break true; + load_ocamlinit ppf; + while true do + let snap = Btype.snapshot () in + try + Lexing.flush_input lb; + Location.reset(); + first_line := true; + let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in + if !Clflags.dump_parsetree then Printast.top_phrase ppf phr; + ignore(execute_phrase true ppf phr) + with + | End_of_file -> exit 0 + | Sys.Break -> fprintf ppf "Interrupted.@."; Btype.backtrack snap + | PPerror -> () + | x -> Errors.report_error ppf x; Btype.backtrack snap + done + +(* Execute a script *) + +let run_script ppf name args = + let len = Array.length args in + if Array.length Sys.argv < len then invalid_arg "Toploop.run_script"; + Array.blit args 0 Sys.argv 0 len; + Obj.truncate (Obj.repr Sys.argv) len; + Arg.current := 0; + Compile.init_path(); + toplevel_env := Compile.initial_env(); + Sys.interactive := false; + use_silently ppf name diff --git a/ocaml-binary-annot/toplevel/toploop.mli b/ocaml-binary-annot/toplevel/toploop.mli new file mode 100644 index 0000000000..35eb5dbf5b --- /dev/null +++ b/ocaml-binary-annot/toplevel/toploop.mli @@ -0,0 +1,112 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Format + +(* Accessors for the table of toplevel value bindings. These functions + must appear as first and second exported functions in this module. + (See module Translmod.) *) +val getvalue : string -> Obj.t +val setvalue : string -> Obj.t -> unit + +(* Set the load paths, before running anything *) + +val set_paths : unit -> unit + +(* The interactive toplevel loop *) + +val loop : formatter -> unit + +(* Read and execute a script from the given file *) + +val run_script : formatter -> string -> string array -> bool + (* true if successful, false if error *) + +(* Interface with toplevel directives *) + +type directive_fun = + | Directive_none of (unit -> unit) + | Directive_string of (string -> unit) + | Directive_int of (int -> unit) + | Directive_ident of (Longident.t -> unit) + | Directive_bool of (bool -> unit) + +val directive_table : (string, directive_fun) Hashtbl.t + (* Table of known directives, with their execution function *) +val toplevel_env : Env.t ref + (* Typing environment for the toplevel *) +val initialize_toplevel_env : unit -> unit + (* Initialize the typing environment for the toplevel *) +val print_exception_outcome : formatter -> exn -> unit + (* Print an exception resulting from the evaluation of user code. *) +val execute_phrase : bool -> formatter -> Parsetree.toplevel_phrase -> bool + (* Execute the given toplevel phrase. Return [true] if the + phrase executed with no errors and [false] otherwise. + First bool says whether the values and types of the results + should be printed. Uncaught exceptions are always printed. *) +val use_file : formatter -> string -> bool +val use_silently : formatter -> string -> bool + (* Read and execute commands from a file. + [use_file] prints the types and values of the results. + [use_silently] does not print them. *) +val eval_path: Path.t -> Obj.t + (* Return the toplevel object referred to by the given path *) + +(* Printing of values *) + +val print_value: Env.t -> Obj.t -> formatter -> Types.type_expr -> unit +val print_untyped_exception: formatter -> Obj.t -> unit + +val install_printer : + Path.t -> Types.type_expr -> (formatter -> Obj.t -> unit) -> unit +val remove_printer : Path.t -> unit + +val max_printer_depth: int ref +val max_printer_steps: int ref + +(* Hooks for external parsers and printers *) + +val parse_toplevel_phrase : (Lexing.lexbuf -> Parsetree.toplevel_phrase) ref +val parse_use_file : (Lexing.lexbuf -> Parsetree.toplevel_phrase list) ref +val print_location : formatter -> Location.t -> unit +val print_error : formatter -> Location.t -> unit +val print_warning : Location.t -> formatter -> Warnings.t -> unit +val input_name : string ref + +val print_out_value : + (formatter -> Outcometree.out_value -> unit) ref +val print_out_type : + (formatter -> Outcometree.out_type -> unit) ref +val print_out_class_type : + (formatter -> Outcometree.out_class_type -> unit) ref +val print_out_module_type : + (formatter -> Outcometree.out_module_type -> unit) ref +val print_out_sig_item : + (formatter -> Outcometree.out_sig_item -> unit) ref +val print_out_signature : + (formatter -> Outcometree.out_sig_item list -> unit) ref +val print_out_phrase : + (formatter -> Outcometree.out_phrase -> unit) ref + +(* Hooks for external line editor *) + +val read_interactive_input : (string -> string -> int -> int * bool) ref + +(* Hooks for initialization *) + +val toplevel_startup_hook : (unit -> unit) ref + +(* Used by Trace module *) + +val may_trace : bool ref diff --git a/ocaml-binary-annot/toplevel/topmain.ml b/ocaml-binary-annot/toplevel/topmain.ml new file mode 100644 index 0000000000..4bf9922a11 --- /dev/null +++ b/ocaml-binary-annot/toplevel/topmain.ml @@ -0,0 +1,93 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Clflags + +let usage = "Usage: ocaml <options> <object-files> [script-file]\noptions are:" + +let preload_objects = ref [] + +let prepare ppf = + Toploop.set_paths (); + try + let res = + List.for_all (Topdirs.load_file ppf) (List.rev !preload_objects) in + !Toploop.toplevel_startup_hook (); + res + with x -> + try Errors.report_error ppf x; false + with x -> + Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x); + false + +let file_argument name = + let ppf = Format.err_formatter in + if Filename.check_suffix name ".cmo" || Filename.check_suffix name ".cma" + then preload_objects := name :: !preload_objects + else + begin + let newargs = Array.sub Sys.argv !Arg.current + (Array.length Sys.argv - !Arg.current) + in + if prepare ppf && Toploop.run_script ppf name newargs + then exit 0 + else exit 2 + end + +let print_version () = + Printf.printf "The Objective Caml toplevel, version %s\n" Sys.ocaml_version; + exit 0; +;; + +let print_version_num () = + Printf.printf "%s\n" Sys.ocaml_version; + exit 0; +;; + +module Options = Main_args.Make_bytetop_options (struct + let set r () = r := true + let clear r () = r := false + + let _I dir = + let dir = Misc.expand_directory Config.standard_library dir in + include_dirs := dir :: !include_dirs + let _init s = init_file := Some s + let _labels = clear classic + let _no_app_funct = clear applicative_functors + let _noassert = set noassert + let _nolabels = set classic + let _noprompt = set noprompt + let _nostdlib = set no_std_include + let _principal = set principal + let _rectypes = set recursive_types + let _strict_sequence = set strict_sequence + let _unsafe = set fast + let _version () = print_version () + let _vnum () = print_version_num () + let _w s = Warnings.parse_options false s + let _warn_error s = Warnings.parse_options true s + let _warn_help = Warnings.help_warnings + let _dparsetree = set dump_parsetree + let _drawlambda = set dump_rawlambda + let _dlambda = set dump_lambda + let _dinstr = set dump_instr + + let anonymous s = file_argument s +end);; + + +let main () = + Arg.parse Options.list file_argument usage; + if not (prepare Format.err_formatter) then exit 2; + Toploop.loop Format.std_formatter diff --git a/ocaml-binary-annot/toplevel/topmain.mli b/ocaml-binary-annot/toplevel/topmain.mli new file mode 100644 index 0000000000..197f88bbc6 --- /dev/null +++ b/ocaml-binary-annot/toplevel/topmain.mli @@ -0,0 +1,17 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Start the [ocaml] toplevel loop *) + +val main: unit -> unit diff --git a/ocaml-binary-annot/toplevel/topstart.ml b/ocaml-binary-annot/toplevel/topstart.ml new file mode 100644 index 0000000000..570e2f203a --- /dev/null +++ b/ocaml-binary-annot/toplevel/topstart.ml @@ -0,0 +1,15 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +let _ = Topmain.main() diff --git a/ocaml-binary-annot/toplevel/trace.ml b/ocaml-binary-annot/toplevel/trace.ml new file mode 100644 index 0000000000..fad92d98a3 --- /dev/null +++ b/ocaml-binary-annot/toplevel/trace.ml @@ -0,0 +1,144 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* The "trace" facility *) + +open Format +open Misc +open Longident +open Types +open Toploop + +type codeptr = Obj.t + +type traced_function = + { path: Path.t; (* Name under which it is traced *) + closure: Obj.t; (* Its function closure (patched) *) + actual_code: codeptr; (* Its original code pointer *) + instrumented_fun: codeptr -> Obj.t -> Obj.t -> Obj.t } + (* Printing function *) + +let traced_functions = ref ([] : traced_function list) + +(* Check if a function is already traced *) + +let is_traced clos = + let rec is_traced = function + [] -> None + | tf :: rem -> if tf.closure == clos then Some tf.path else is_traced rem + in is_traced !traced_functions + +(* Get or overwrite the code pointer of a closure *) + +let get_code_pointer cls = Obj.field cls 0 + +let set_code_pointer cls ptr = Obj.set_field cls 0 ptr + +(* Call a traced function (use old code pointer, but new closure as + environment so that recursive calls are also traced). + It is necessary to wrap Meta.invoke_traced_function in an ML function + so that the RETURN at the end of the ML wrapper takes us to the + code of the function. *) + +let invoke_traced_function codeptr env arg = + Meta.invoke_traced_function codeptr env arg + +let print_label ppf l = if l <> "" then fprintf ppf "%s:" l + +(* If a function returns a functional value, wrap it into a trace code *) + +let rec instrument_result env name ppf clos_typ = + match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with + | Tarrow(l, t1, t2, _) -> + let starred_name = + match name with + | Lident s -> Lident(s ^ "*") + | Ldot(lid, s) -> Ldot(lid, s ^ "*") + | Lapply(l1, l2) -> fatal_error "Trace.instrument_result" in + let trace_res = instrument_result env starred_name ppf t2 in + (fun clos_val -> + Obj.repr (fun arg -> + if not !may_trace then + (Obj.magic clos_val : Obj.t -> Obj.t) arg + else begin + may_trace := false; + try + fprintf ppf "@[<2>%a <--@ %a%a@]@." + Printtyp.longident starred_name + print_label l + (print_value !toplevel_env arg) t1; + may_trace := true; + let res = (Obj.magic clos_val : Obj.t -> Obj.t) arg in + may_trace := false; + fprintf ppf "@[<2>%a -->@ %a@]@." + Printtyp.longident starred_name + (print_value !toplevel_env res) t2; + may_trace := true; + trace_res res + with exn -> + may_trace := false; + fprintf ppf "@[<2>%a raises@ %a@]@." + Printtyp.longident starred_name + (print_value !toplevel_env (Obj.repr exn)) Predef.type_exn; + may_trace := true; + raise exn + end)) + | _ -> (fun v -> v) + +(* Same as instrument_result, but for a toplevel closure (modified in place) *) + +let instrument_closure env name ppf clos_typ = + match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with + | Tarrow(l, t1, t2, _) -> + let trace_res = instrument_result env name ppf t2 in + (fun actual_code closure arg -> + if not !may_trace then begin + let res = invoke_traced_function actual_code closure arg + in res (* do not remove let, prevents tail-call to invoke_traced_ *) + end else begin + may_trace := false; + try + fprintf ppf "@[<2>%a <--@ %a%a@]@." + Printtyp.longident name + print_label l + (print_value !toplevel_env arg) t1; + may_trace := true; + let res = invoke_traced_function actual_code closure arg in + may_trace := false; + fprintf ppf "@[<2>%a -->@ %a@]@." + Printtyp.longident name + (print_value !toplevel_env res) t2; + may_trace := true; + trace_res res + with exn -> + may_trace := false; + fprintf ppf "@[<2>%a raises@ %a@]@." + Printtyp.longident name + (print_value !toplevel_env (Obj.repr exn)) Predef.type_exn; + may_trace := true; + raise exn + end) + | _ -> assert false + +(* Given the address of a closure, find its tracing info *) + +let rec find_traced_closure clos = function + | [] -> fatal_error "Trace.find_traced_closure" + | f :: rem -> if f.closure == clos then f else find_traced_closure clos rem + +(* Trace the application of an (instrumented) closure to an argument *) + +let print_trace clos arg = + let f = find_traced_closure clos !traced_functions in + f.instrumented_fun f.actual_code clos arg diff --git a/ocaml-binary-annot/toplevel/trace.mli b/ocaml-binary-annot/toplevel/trace.mli new file mode 100644 index 0000000000..d708361c7c --- /dev/null +++ b/ocaml-binary-annot/toplevel/trace.mli @@ -0,0 +1,35 @@ +(***********************************************************************) +(* *) +(* 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* The "trace" facility *) + +open Format + +type codeptr + +type traced_function = + { path: Path.t; (* Name under which it is traced *) + closure: Obj.t; (* Its function closure (patched) *) + actual_code: codeptr; (* Its original code pointer *) + instrumented_fun: codeptr -> Obj.t -> Obj.t -> Obj.t } + (* Printing function *) + +val traced_functions: traced_function list ref +val is_traced: Obj.t -> Path.t option +val get_code_pointer: Obj.t -> codeptr +val set_code_pointer: Obj.t -> codeptr -> unit +val instrument_closure: + Env.t -> Longident.t -> formatter -> Types.type_expr -> + codeptr -> Obj.t -> Obj.t -> Obj.t +val print_trace: Obj.t -> Obj.t -> Obj.t |