diff options
Diffstat (limited to 'tools')
| -rw-r--r-- | tools/Makefile | 14 | ||||
| -rw-r--r-- | tools/Makefile.cmt2annot | 12 | ||||
| -rw-r--r-- | tools/Makefile.cmt2info | 12 | ||||
| -rw-r--r-- | tools/Makefile.cmt2ml | 12 | ||||
| -rw-r--r-- | tools/Makefile.rules | 47 | ||||
| -rw-r--r-- | tools/Readme.txt | 9 | ||||
| -rw-r--r-- | tools/cmt2annot.ml | 301 | ||||
| -rw-r--r-- | tools/cmt2info.ml | 153 | ||||
| -rw-r--r-- | tools/cmt2ml.ml | 83 |
9 files changed, 643 insertions, 0 deletions
diff --git a/tools/Makefile b/tools/Makefile new file mode 100644 index 0000000000..1aacc1eaca --- /dev/null +++ b/tools/Makefile @@ -0,0 +1,14 @@ + +all: + $(MAKE) -f Makefile.cmt2annot + $(MAKE) -f Makefile.cmt2ml + $(MAKE) -f Makefile.cmt2info + +depend: + rm -f .depend + $(MAKE) -f Makefile.cmt2annot depend + $(MAKE) -f Makefile.cmt2ml depend + $(MAKE) -f Makefile.cmt2info depend + +clean: + rm -f *.o *.cm? *.cm?? *~ *.byte *.opt *.cmt *.cmti *.annot diff --git a/tools/Makefile.cmt2annot b/tools/Makefile.cmt2annot new file mode 100644 index 0000000000..6327348cc9 --- /dev/null +++ b/tools/Makefile.cmt2annot @@ -0,0 +1,12 @@ +TARGET=cmt2annot +MLIS= +MLS=cmt2annot.ml +CMAS= unix.cma toplevellib.cma +INCLUDES= \ + -I ../ocaml-binary-annot/typing \ + -I ../ocaml-binary-annot/parsing \ + -I ../ocaml-binary-annot/utils \ + +OFLAGS=-g -annot + +include Makefile.rules diff --git a/tools/Makefile.cmt2info b/tools/Makefile.cmt2info new file mode 100644 index 0000000000..8b1f4233f4 --- /dev/null +++ b/tools/Makefile.cmt2info @@ -0,0 +1,12 @@ +TARGET=cmt2info +MLIS= +MLS=cmt2info.ml +CMAS= unix.cma toplevellib.cma +INCLUDES= \ + -I ../ocaml-binary-annot/typing \ + -I ../ocaml-binary-annot/parsing \ + -I ../ocaml-binary-annot/utils \ + +OFLAGS=-g -annot + +include Makefile.rules diff --git a/tools/Makefile.cmt2ml b/tools/Makefile.cmt2ml new file mode 100644 index 0000000000..b034e7b9cd --- /dev/null +++ b/tools/Makefile.cmt2ml @@ -0,0 +1,12 @@ +TARGET=cmt2ml +MLIS= +MLS=cmt2ml.ml +CMAS= unix.cma toplevellib.cma +INCLUDES= \ + -I ../ocaml-binary-annot/typing \ + -I ../ocaml-binary-annot/parsing \ + -I ../ocaml-binary-annot/utils \ + +OFLAGS=-g -annot + +include Makefile.rules diff --git a/tools/Makefile.rules b/tools/Makefile.rules new file mode 100644 index 0000000000..4b68ee723e --- /dev/null +++ b/tools/Makefile.rules @@ -0,0 +1,47 @@ +OCAMLC=ocamlc.opt +OCAMLOPT=ocamlopt.opt +OCAMLYACC=ocamlyacc +OCAMLLEX=ocamllex.opt +OCAMLDEP=ocamldep.opt + +CMXS=$(MLS:.ml=.cmx) +CMIS=$(MLS:.ml=.cmi) +CMOS=$(MLS:.ml=.cmo) +OBJS=$(CMXS:.cmx=.o) +CMXAS=$(CMAS:.cma=.cmxa) +ANNOTS=$(MLS:.ml=.annot) + +all: $(TARGET).byte +clean: + rm -f *~ $(TARGET) $(OBJS) $(CMXS) $(CMIS) $(CMOS) $(CMXAS) $(ANNOTS) + +depend: + $(OCAMLDEP) $(INCLUDES) $(MLS) $(MLIS) >> .depend + +$(TARGET).opt: $(CMXS) + $(OCAMLOPT) -o $(TARGET).opt $(CMXAS) $(CMXS) + +$(TARGET).byte: $(CMOS) + $(OCAMLC) -o $(TARGET).byte $(CMAS) $(CMOS) + +.SUFFIXES: .mli .mll .mly .ml .cmx .cmo .cmi + +.ml.cmo: + $(OCAMLC) $(OFLAGS) $(INCLUDES) -c $(MOREFLAGS) $< + +.ml.cmx: + $(OCAMLOPT) $(OFLAGS) $(INCLUDES) -c $(MOREFLAGS) $< + +.mli.cmi: + $(OCAMLC) $(OFLAGS) $(INCLUDES) -c $(MOREFLAGS) $< + +.mll.ml : + $(OCAMLLEX) $< + +.mly.ml : + $(OCAMLYACC) $< + +.mly.mli: + $(OCAMLYACC) $< + +-include .depend diff --git a/tools/Readme.txt b/tools/Readme.txt new file mode 100644 index 0000000000..90a67d190b --- /dev/null +++ b/tools/Readme.txt @@ -0,0 +1,9 @@ +Placer dans ce répertoire tous les nouveaux outils: +=================================================== +- cmt2annot: generates a .annot file from a .cmt file +- cmt2src: generates a .ml file back from a .cmt file + +Faire une analyse de code mort: +=============================== + +Lire tous les fichiers diff --git a/tools/cmt2annot.ml b/tools/cmt2annot.ml new file mode 100644 index 0000000000..2e7681837c --- /dev/null +++ b/tools/cmt2annot.ml @@ -0,0 +1,301 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Fabrice Le Fessant, projet OCamlPro, INRIA Rocquencourt *) +(* *) +(* Copyright 2010 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. *) +(* *) +(***********************************************************************) +(* +Generate .annot file from a .types files. +*) + +open Typedtree + +let pattern_scopes = ref [] + +let push_None () = + pattern_scopes := None :: !pattern_scopes +let push_Some annot = + pattern_scopes := (Some annot) :: !pattern_scopes +let pop_scope () = + match !pattern_scopes with + [] -> assert false + | _ :: scopes -> pattern_scopes := scopes + +module ForIterator = struct + open Asttypes + + include DefaultIteratorArgument + + let structure_begin_scopes = ref [] + let structure_end_scopes = ref [] + + let rec find_last list = + match list with + [] -> assert false + | [x] -> x + | _ :: tail -> find_last tail + + let enter_structure str = + match str.str_items with + [] -> () + | _ -> + let loc = + match !structure_end_scopes with + [] -> Location.none + | _ -> + let s = find_last str.str_items in + s.str_loc + in + structure_end_scopes := loc :: !structure_end_scopes; + + let rec iter list = + match list with + [] -> assert false + | [ { str_desc = Tstr_value (Nonrecursive, _); str_loc = loc } ] -> + structure_begin_scopes := loc.Location.loc_end + :: !structure_begin_scopes + | [ _ ] -> () + | item :: tail -> + iter tail; + match item, tail with + { str_desc = Tstr_value (Nonrecursive,_) }, + { str_loc = loc } :: _ -> + structure_begin_scopes := loc.Location.loc_start + :: !structure_begin_scopes + | _ -> () + in + iter str.str_items + + let leave_structure str = + match str.str_items with + [] -> () + | _ -> + match !structure_end_scopes with + [] -> assert false + | _ :: scopes -> structure_end_scopes := scopes + + let enter_class_expr node = + Stypes.record (Stypes.Ti_class node) + let enter_module_expr node = + Stypes.record (Stypes.Ti_mod node) + + let add_variable pat id = + match !pattern_scopes with + | [] -> assert false + | None :: _ -> () + | (Some s) :: _ -> + Stypes.record (Stypes.An_ident (pat.pat_loc, Ident.name id, s)) + + let enter_pattern pat = + match pat.pat_desc with + | Tpat_var id + | Tpat_alias (_, TPat_alias id) + + -> add_variable pat id + + | Tpat_alias (_, (TPat_constraint _ | TPat_type _) ) + | Tpat_any _ -> () + | Tpat_constant _ + | Tpat_tuple _ + | Tpat_construct _ + | Tpat_lazy _ + | Tpat_or _ + | Tpat_array _ + | Tpat_record _ + | Tpat_variant _ + -> () + + let leave_pattern pat = + Stypes.record (Stypes.Ti_pat pat) + + let rec name_of_path = function + | Path.Pident id -> Ident.name id + | Path.Pdot(p, s, pos) -> + if Oprint.parenthesized_ident s then + name_of_path p ^ ".( " ^ s ^ " )" + else + name_of_path p ^ "." ^ s + | Path.Papply(p1, p2) -> name_of_path p1 ^ "(" ^ name_of_path p2 ^ ")" + + let enter_expression exp = + match exp.exp_desc with + Texp_ident (path, _) -> + let full_name = name_of_path path in + begin + try + let annot = Env.find_annot path exp.exp_env in + Stypes.record + (Stypes.An_ident (exp.exp_loc, full_name , annot)) + with Not_found -> + Printf.fprintf stderr "Path %s not found in env\n%!" + full_name; + end + + | Texp_let (rec_flag, _, body) -> + begin + match rec_flag with + | Recursive -> push_Some (Annot.Idef exp.exp_loc) + | Nonrecursive -> push_Some (Annot.Idef body.exp_loc) + | Default -> push_None () + end + | Texp_function _ -> push_None () + | Texp_match _ -> push_None () + | Texp_try _ -> push_None () + | _ -> () + + let leave_expression exp = + if not exp.exp_loc.Location.loc_ghost then + Stypes.record (Stypes.Ti_expr exp); + match exp.exp_desc with + | Texp_let _ + | Texp_function _ + | Texp_match _ + | Texp_try _ + -> pop_scope () + | _ -> () + + let enter_binding pat exp = + let scope = + match !pattern_scopes with + | [] -> assert false + | None :: _ -> Some (Annot.Idef exp.exp_loc) + | scope :: _ -> scope + in + pattern_scopes := scope :: !pattern_scopes + + let leave_binding _ _ = + pop_scope () + + let enter_class_expr exp = + match exp.cl_desc with + | Tcl_fun _ -> push_None () + | Tcl_let _ -> push_None () + | _ -> () + + let leave_class_expr exp = + match exp.cl_desc with + | Tcl_fun _ + | Tcl_let _ -> pop_scope () + | _ -> () + + let enter_class_structure _ = + push_None () + + let leave_class_structure _ = + pop_scope () + + let enter_class_field cf = + match cf.cf_desc with + Tcf_let _ -> push_None () + | _ -> () + + let leave_class_field cf = + match cf.cf_desc with + Tcf_let _ -> pop_scope () + | _ -> () + + + let enter_structure_item s = + Stypes.record_phrase s.str_loc; + match s.str_desc with + Tstr_value (rec_flag, _) -> + begin + let loc = s.str_loc in + let scope = match !structure_end_scopes with + [] -> assert false + | scope :: _ -> scope + in + match rec_flag with + | Recursive -> push_Some + (Annot.Idef { scope with + Location.loc_start = loc.Location.loc_start}) + | Nonrecursive -> +(* TODO: do it lazily, when we start the next element ! *) +(* + let start = match srem with + | [] -> loc.Location.loc_end + | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start +in *) + let start = + match !structure_begin_scopes with + [] -> assert false + | loc :: tail -> + structure_begin_scopes := tail; + loc + in + push_Some (Annot.Idef {scope with Location.loc_start = start}) + | Default -> push_None () + end + | _ -> () + + let leave_structure_item s = + match s.str_desc with + Tstr_value _ -> pop_scope () + | _ -> () + + + end + + + +module Iterator = MakeIterator(ForIterator) + + +let init_path () = + let dirs = + if !Clflags.use_threads then "+threads" :: !Clflags.include_dirs + else if !Clflags.use_vmthreads then "+vmthreads" :: !Clflags.include_dirs + else !Clflags.include_dirs in + let exp_dirs = + List.map (Misc.expand_directory Config.standard_library) dirs in + Config.load_path := "" :: List.rev_append exp_dirs (Clflags.std_include_dir ()); + Env.reset_cache () + +open Clflags + +(* +TODO: external functions have no annotations ! fix typecore.ml ! +TODO: Texp_for bound idents have no annoations ! fix typecore.ml ! + *) + +let arg_list = [ + "-I", Arg.String (fun filename -> + include_dirs := filename :: !include_dirs), + "<dir> Add <dir> to the list of include directories"; + + "-thread", Arg.Unit (fun _ -> use_threads := true), + " Generate code that supports the system threads library"; + + "-vmthread", Arg.Unit (fun _ -> use_vmthreads := true), + " Generate code that supports the threads library with VM-level\n\ + \ scheduling" + + + ] + +let arg_usage = " ...<file>.cmt : generates <file>.annot from cmt file" + +let _ = + Clflags.annotations := true; + + Arg.parse arg_list (fun filename -> + if Filename.check_suffix filename ".cmt" then begin + init_path(); + let ic = open_in filename in + let (types : saved_type array) = input_value ic in + close_in ic; + match types with + [| Saved_implementation typedtree |] -> + Iterator.iter_structure typedtree; + Stypes.dump ((Filename.chop_suffix filename ".cmt") ^ ".annot") + | _ -> + Printf.fprintf stderr "File was generated with an error\n%!"; + exit 2 + end else + Arg.usage arg_list arg_usage + ) arg_usage diff --git a/tools/cmt2info.ml b/tools/cmt2info.ml new file mode 100644 index 0000000000..f8535b66a6 --- /dev/null +++ b/tools/cmt2info.ml @@ -0,0 +1,153 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Fabrice Le Fessant, projet OCamlPro, INRIA Rocquencourt *) +(* *) +(* Copyright 2010 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. *) +(* *) +(***********************************************************************) +(* +Generate .annot file from a .types files. +*) + +open Typedtree + + +let load_cmt_or_exit filename = + try + let ic = open_in filename in + let (types : saved_type array) = input_value ic in + close_in ic; + match types with + [| Saved_implementation typedtree |] -> typedtree + | _ -> + Printf.fprintf stderr "File was generated with an error\n%!"; + exit 2 + with e -> + Printf.fprintf stderr "Error %s while loading %s\n%!" (Printexc.to_string e) filename; + exit 2 + +let load_cmti_or_exit filename = + try + let ic = open_in filename in + let (types : saved_type array) = input_value ic in + close_in ic; + match types with + [| Saved_signature typedtree |] -> typedtree + | _ -> + Printf.fprintf stderr "File was generated with an error\n%!"; + exit 2 + with e -> + Printf.fprintf stderr "Error %s while loading %s\n%!" (Printexc.to_string e) filename; + exit 2 + +let directories = ref [] + +let arg_list = [ + "-I", Arg.String (fun filename -> directories := filename :: !directories), + "<dir> Add <dir> to the list of include directories"; + ] + +let arg_usage = " ... : generates some information from .cmt/.cmti files" + +let _ = + Arg.parse arg_list (fun filename -> Arg.usage arg_list arg_usage) arg_usage + +module StringMap = Map.Make(struct type t = string let compare = compare end) + +type cmt = { + cmt_modname : string; + cmt_filename : string; + cmt_typedtree : Typedtree.structure; +} + +type cmti = { + cmti_modname : string; + cmti_filename : string; + cmti_typedtree : Typedtree.signature; +} + +let cmts = ref StringMap.empty +let cmtis = ref StringMap.empty + +let first_cmt = ref None + +let add_cmt filename = + let typedtree = load_cmt_or_exit filename in + Printf.printf "%s loaded\n%!" filename; + let modname = String.capitalize (Filename.basename (Filename.chop_suffix filename ".cmt")) in + let cmt = { + cmt_modname = modname; + cmt_filename = filename; + cmt_typedtree = typedtree; + } in + first_cmt := Some cmt; + cmts := StringMap.add modname cmt !cmts + +let add_cmti filename = + let typedtree = load_cmti_or_exit filename in + Printf.printf "%s loaded\n%!" filename; + let modname = String.capitalize (Filename.basename (Filename.chop_suffix filename ".cmti")) in + let cmti = { + cmti_modname = modname; + cmti_filename = filename; + cmti_typedtree = typedtree; + } in + cmtis := StringMap.add modname cmti !cmtis + +let _ = + List.iter (fun dirname -> + let dir = Unix.opendir dirname in + begin + try + while true do + let file = Unix.readdir dir in + if Filename.check_suffix file ".cmt" then + let filename = Filename.concat dirname file in + add_cmt filename + else + if Filename.check_suffix file ".cmti" then + let filename = Filename.concat dirname file in + add_cmti filename + done + with End_of_file -> () + end; + Unix.closedir dir; + + ) !directories + +let cmts = !cmts +let cmtis = !cmtis + + +let current_cmt = ref (match !first_cmt with None -> assert false | Some cmt -> cmt) + +let get_path path = () + +module ForIterator = struct + open Asttypes + open Types + open Typedtree + + include DefaultIteratorArgument + + let enter_expression e = + match e.exp_desc with + Texp_ident (path, { val_kind = Val_reg}) -> + () + | _ -> () + end + +module Iterator = MakeIterator(ForIterator) + +let set_iterator cmt = + current_cmt := cmt + +let _ = + StringMap.iter (fun _ cmt -> + set_iterator cmt; + Iterator.iter_structure cmt.cmt_typedtree + ) cmts diff --git a/tools/cmt2ml.ml b/tools/cmt2ml.ml new file mode 100644 index 0000000000..f9418cf6d0 --- /dev/null +++ b/tools/cmt2ml.ml @@ -0,0 +1,83 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Fabrice Le Fessant, projet OCamlPro, INRIA Rocquencourt *) +(* *) +(* Copyright 2010 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. *) +(* *) +(***********************************************************************) + +open Typedtree + +let arg_list = [] +let arg_usage = " ...<file>.cmt : generates <file>.cmt.ml from cmt file" + +let load_cmt_or_exit filename = + try + let ic = open_in filename in + let (types : saved_type array) = input_value ic in + close_in ic; + match types with + [| Saved_implementation typedtree |] -> typedtree + | _ -> + Printf.fprintf stderr "File was generated with an error\n%!"; + exit 2 + with e -> + Printf.fprintf stderr "Error %s while loading %s\n%!" (Printexc.to_string e) filename; + exit 2 + +let load_cmti_or_exit filename = + try + let ic = open_in filename in + let (types : saved_type array) = input_value ic in + close_in ic; + match types with + [| Saved_signature typedtree |] -> typedtree + | _ -> + Printf.fprintf stderr "File was generated with an error\n%!"; + exit 2 + with e -> + Printf.fprintf stderr "Error %s while loading %s\n%!" (Printexc.to_string e) filename; + exit 2 + +let _ = + Clflags.annotations := true; + + Arg.parse arg_list (fun filename -> + if Filename.check_suffix filename ".cmt" then begin + let ic = open_in filename in + let (types : saved_type array) = input_value ic in + close_in ic; + match types with + [| Saved_implementation typedtree |] -> + let filename = filename ^ ".ml" in + let oc = open_out filename in + let ppf = Format.formatter_of_out_channel oc in + Pprintast.print_structure ppf (Untypeast.untype_structure typedtree); + Format.pp_print_flush ppf (); + close_out oc; + | _ -> + Printf.fprintf stderr "File was generated with an error\n%!"; + exit 2 + end else + if Filename.check_suffix filename ".cmti" then begin + let ic = open_in filename in + let (types : saved_type array) = input_value ic in + close_in ic; + match types with + [| Saved_signature typedtree |] -> + let filename = filename ^ ".mli" in + let oc = open_out filename in + let ppf = Format.formatter_of_out_channel oc in + Pprintast.print_signature ppf (Untypeast.untype_signature typedtree); + Format.pp_print_flush ppf (); + close_out oc; + | _ -> + Printf.fprintf stderr "File was generated with an error\n%!"; + exit 2 + end else + Arg.usage arg_list arg_usage + ) arg_usage |