Commits

camlspotter committed eada479 Merge

merge

  • Participants
  • Parent commits bb6ba98, 270c49b
  • Tags working2

Comments (0)

Files changed (5)

File ocamlspot.ml

 
   let rannots_full file = 
     eprintf "@[<2>rannots =@ [ @[<v>%a@]@] ]@."
-      (Format.list ";@ " (Regioned.format Annot.format))
-      file.File.rannots
+      (Format.list ";@ " (Regioned.format (Format.list ";@ " Annot.format)))
+      !!(file.File.rannots)
   ;;
   
   let rannots_summary file = 
     eprintf "@[<2>rannots =@ [ @[<v>%a@]@] ]@."
-      (Format.list ";@ " (Regioned.format Annot.summary))
-      file.File.rannots
+      (Format.list ";@ " (Regioned.format (Format.list ";@ " Annot.summary)))
+      !!(file.File.rannots)
   ;;
   
   let tree file = Tree.dump !!(file.File.tree)
       List.map fst (Tree.find_path_contains probe !!(file.File.tree))
     in
     match treepath with
-    | [] -> 
-	failwith (Printf.sprintf "nothing at %s" (Position.to_string pos))
+    | [] -> failwith (Printf.sprintf "nothing at %s" (Position.to_string pos))
     | { Regioned.region = r; _ } :: _ ->
 	
 	(* find annots bound to the region *)
         let annots = 
-	  List.filter_map (fun rannot ->
+	  List.concat_map (fun rannot ->
 	    if Region.compare r rannot.Regioned.region = `Same then 
-	      Some rannot.Regioned.value
-	    else None)
+	      rannot.Regioned.value
+	    else [])
 	    treepath
         in
 
         printf "XTree: <%s:%s>@." file.File.path (Region.to_string r);
 
 	(* Find the innermost module *)
-        let rec find_module_path = function
-          | [] -> []
-          | { Regioned.value = Annot.Str (Abstraction.AStr_module (id, _)); _ } :: ls
-          | { Regioned.value = Annot.Str (Abstraction.AStr_modtype (id, _)); _ } :: ls ->
-              id :: find_module_path ls
-          | _ :: ls -> find_module_path ls
+        let find_module_path treepath = List.concat_map (fun { Regioned.value = annots } ->
+          List.filter_map (function 
+            | Annot.Str (Abstraction.AStr_module (id, _)) -> Some id
+            | _ -> None) annots) treepath
         in
         printf "In_module: %s@."
           (String.concat "." (List.map Ident0.name (List.rev (find_module_path treepath))));
 	    | Path.Papply _ -> assert false
 	  in
 	  let base = base_ident path in
-	  List.iter (function
-	    | { Regioned.region= region; value= Annot.Use (k', path'); } when k = k' && base = base_ident path' ->
-	      begin match query_by_kind_path file k' path' with
-	      | Some found' when found = found' ->
-		  printf "<%s:%s>: %s@." 
-		    file.File.path
-		    (Region.to_string region)
-		    (Path.name path)
-	      | None | Some _ -> ()
-	      end
-	    | _ -> ()) file.File.rannots
+	  List.iter (fun { Regioned.region= region; value= annots } -> 
+                List.iter (function
+                  | Annot.Use (k', path') when k = k' && base = base_ident path' ->
+	              begin match query_by_kind_path file k' path' with
+	              | Some found' when found = found' ->
+		          printf "<%s:%s>: %s@." 
+		            file.File.path
+		            (Region.to_string region)
+		            (Path.name path)
+	              | None | Some _ -> ()
+	              end
+                  | _ -> ()) annots) !!(file.File.rannots)
 	| _ -> ());
     in
 
       (Type _ | Str _ | Module _ | Functor_parameter _ | Use _ | Non_expansive _
           | Mod_type _) -> false 
 
-  (* CR jfuruse: A Location.t contains a filename, though it is always
-     unique. Waste of 4xn bytes. *)
-  let recorded = (Hashtbl.create 1023 : (Location.t, (int * t list)) Hashtbl.t)
-
-  let clear () = Hashtbl.clear recorded
-
-  type location_property = Wellformed | Flipped | Over_files | Illformed
-
-  let check_location loc = 
-    if loc.Location.loc_start == Lexing.dummy_pos || loc.Location.loc_end == Lexing.dummy_pos then Illformed
-    else if loc.Location.loc_start = Lexing.dummy_pos || loc.Location.loc_end = Lexing.dummy_pos then Illformed
-    else 
-      (* If the file name is different between the start and the end, we cannot tell the wellformedness. *)
-      if loc.Location.loc_start.Lexing.pos_fname <> loc.Location.loc_end.Lexing.pos_fname then Over_files
-      else
-        (* P4 creates some flipped locations where loc_start > loc_end *)
-        match compare loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum 
-        with
-        | -1 | 0 -> Wellformed
-        | _ -> Flipped
-
-  let record loc t = 
-    let really_record () = 
-      let num_records, records = 
-        try Hashtbl.find recorded loc with Not_found -> 0, []
-      in
-      (* CR jfuruse: I am not really sure the below is correct now, 
-         but I remember the huge compilation slow down... *)
-      (* This caching works horribly when too many things are defined 
-         at the same location. For example, a type definition of more than 
-         3000 variants, with sexp camlp4 extension, the compile time explodes
-         from 10secs to 4mins! Therefore this works 
-         only if [num_records <= 10] 
-      *)
-      if num_records <= 10 && List.exists (equal t) records then ()
-      else Hashtbl.replace recorded loc (num_records + 1, t :: records)
-    in
-    match check_location loc with
-    | Wellformed -> really_record ()
-    | Flipped -> 
-        if not loc.Location.loc_ghost then Format.eprintf "%aWarning: Flipped location.@." Location.print loc; 
-        really_record ()
-    | Illformed -> 
-        if not loc.Location.loc_ghost then Format.eprintf "%aWarning: Ill-formed location.@." Location.print loc
-    | Over_files -> ()
-
-  let record_constr_type_use loc ty =
-    let path_of_constr_type t =
-      let t = Ctype.repr t in 
-      match (Ctype.repr t).Types.desc with
-      | Types.Tconstr (p, _, _) -> Some p
-      | _ ->
-          Format.eprintf "Error: Spot.Annot.record_constr_type_use: not a constructor type: %a@." (Printtyp.type_expr ~with_pos:false) ty;
-          None
-    in
-    match path_of_constr_type ty with
-    | Some path -> record loc (Use (Kind.Type, path))
-    | None -> ()
-
-  let record_module_expr_def loc id modl =
-    protect "Spot.Annot.record_module_expr_def" (fun () ->
-      record loc (Str (Abstraction.AStr_module 
-	                  (id, 
-	                  (Abstraction.module_expr modl)))))
-      ()
-    
-  let record_module_expr_use loc modl =
-    protect "Spot.Annot.record_module_expr_use" (fun () ->
-      record loc (Module (Abstraction.module_expr modl));
-      record loc (Mod_type modl.Typedtree.mod_type))
-      ()
-
-(*
-  let record_include_sig loc mty sg =
-    protect "Spot.Annot.record_include_sig" (fun () ->
-      let kids = (* CR jfuruse: copy of structure_item_sub *) 
-	List.concat_map Abstraction.T.kident_of_sigitem sg
-      in
-      let sitem = Abstraction.AStr_include (Abstraction.module_type mty, kids)
-      in 
-      (* ocaml signature simply forgets the fact that kids are
-	 included. We memorize them here. *)
-      List.iter (fun (_,id) ->
-	Hashtbl.add
-          Abstraction.included_sig_identifier_table
-	  id (sitem, ref false (* never recorded in the parent sig yet *))) kids;
-      record loc (Str sitem))
-      ()
-*)
-
   module Record = struct
     open Asttypes
     open Typedtree
     open Abstraction
 
-    let record_record loc typ = 
+    (* CR jfuruse: A Location.t contains a filename, though it is always
+       unique. Waste of 4xn bytes. *)
+  (*
+    let recorded = (Hashtbl.create 1023 : (Location.t, (int * t list)) Hashtbl.t)
+  
+    let clear () = Hashtbl.clear recorded
+  *)
+  
+    type location_property = Wellformed | Flipped | Over_files | Illformed | Ghost
+  
+    let check_location loc = 
+      if loc.Location.loc_ghost then Ghost
+      else if loc.Location.loc_start == Lexing.dummy_pos || loc.Location.loc_end == Lexing.dummy_pos then Illformed
+      else if loc.Location.loc_start = Lexing.dummy_pos || loc.Location.loc_end = Lexing.dummy_pos then Illformed
+      else 
+        (* If the file name is different between the start and the end, we cannot tell the wellformedness. *)
+        if loc.Location.loc_start.Lexing.pos_fname <> loc.Location.loc_end.Lexing.pos_fname then Over_files
+        else
+          (* P4 creates some flipped locations where loc_start > loc_end *)
+          match compare loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum 
+          with
+          | -1 | 0 -> Wellformed
+          | _ -> Flipped
+  
+    let record tbl loc t = 
+      let really_record () = 
+        let num_records, records = 
+          try Hashtbl.find tbl loc with Not_found -> 0, []
+        in
+        (* CR jfuruse: I am not really sure the below is correct now, 
+           but I remember the huge compilation slow down... *)
+        (* This caching works horribly when too many things are defined 
+           at the same location. For example, a type definition of more than 
+           3000 variants, with sexp camlp4 extension, the compile time explodes
+           from 10secs to 4mins! Therefore this works 
+           only if [num_records <= 10] 
+        *)
+        if num_records <= 10 && List.exists (equal t) records then ()
+        else Hashtbl.replace tbl loc (num_records + 1, t :: records)
+      in
+      match check_location loc with
+      | Wellformed -> really_record ()
+      | Flipped -> 
+          if not loc.Location.loc_ghost then Format.eprintf "%aWarning: Flipped location.@." Location.print loc; 
+          really_record ()
+      | Illformed -> 
+          if not loc.Location.loc_ghost then Format.eprintf "%aWarning: Ill-formed location.@." Location.print loc
+      | Ghost -> () (* just useless, i guess *)  
+      | Over_files -> ()
+
+    let record_record tbl loc typ = 
       let open Types in
       let open Ctype in
       match (repr typ).desc with
-      | Tconstr (path, _, _) -> record loc (Use (Kind.Type, path)) 
+      | Tconstr (path, _, _) -> record tbl loc (Use (Kind.Type, path)) 
       | _ -> (* strange.. *) ()
 
-    class fold = object 
+    class fold tbl = let record = record tbl in object 
       inherit Ttfold.fold as super
 
       method! pattern p = 
         record p.pat_loc (Type (p.pat_type, p.pat_env, `Pattern));
         begin match p.pat_desc with
-        | Tpat_record _ -> record_record p.pat_loc p.pat_type
+        | Tpat_record _ -> record_record tbl p.pat_loc p.pat_type
         | _ -> ()
         end;
         super#pattern p
       method! expression e = 
         record e.exp_loc (Type (e.exp_type, e.exp_env, `Expr));
         begin match e.exp_desc with
-        | Texp_record _ -> record_record e.exp_loc e.exp_type
+        | Texp_record _ -> record_record tbl e.exp_loc e.exp_type
         | _ -> ()
         end;
         super#expression e
     end
   end
 
-  let get_recorded () = Hashtbl.fold (fun k (_,vs) st -> 
-    List.map (fun v -> k,v) vs @ st) recorded []
-
   let record_structure str = 
     protect' "Spot.Annot.record_structure" (fun () ->
-      Hashtbl.clear recorded;
-      let o = new Record.fold in
+      let tbl = Hashtbl.create 1023 in
+      let o = new Record.fold tbl in
       ignore (o#structure str);
-      get_recorded ())
+      tbl)
       ()
 
   let record_signature sg = 
     protect' "Spot.Annot.record_signature" (fun () ->
-      Hashtbl.clear recorded;
-      let o = new Record.fold in
+      let tbl = Hashtbl.create 1023 in
+      let o = new Record.fold tbl in
       ignore (o#signature sg);
-      get_recorded ())
+      tbl)
       ()
 
   let string_of_at = function
       { region = r12; value = v }) 
 
   let format f ppf { region = r; value = v } =
-    fprintf ppf "@[<2>%s: %a@]" 
+    fprintf ppf "@[<2>%s:@ @[%a@]@]" 
       (Region.to_string r) 
       f v
 end
 
 (* annotation with region *)
 module RAnnot = struct
-  type t      = Annot.t Regioned.t
+  type t      = Annot.t list Regioned.t
   let split   = Regioned.split
   let compare = Regioned.compare
-  let format  = Regioned.format Annot.format
+  let format  = Regioned.format (Format.list ";@ " Annot.format)
 end
 
 module Tree = struct
   let iter = iter_elem
 
   let find_path_contains r t = 
-    let probe = { region = r; value = Annot.dummy } in
+    let probe = { region = r; value = [] (* dummy *) } in
     find_path_contains probe t
 
   let dump t = 
 	  | None -> fprintf ppf "ROOT"
 	  | Some rrspot -> RAnnot.format ppf rrspot
 	in
-	eprintf "@[<2>%a =>@ %a@]@."
+	eprintf "@[<2>@[%a@] =>@ @[%a@]@]@."
 	  format_parent parent
 	  RAnnot.format rrspot) t
 end
     | Functor_parameter of Ident.t
     | Non_expansive of bool
 
-  val record : Location.t -> t -> unit
-    
-  (* [record_constr_type_use loc ty] records a constructor use of type [ty]
-     at the location [loc]. [ty] must be a constructor type, otherwise,
-     an error message is printed out. 
-  *)
-(*
-  val record_constr_type_use : Location.t -> Types.type_expr -> unit
-  val record_module_expr_def : Location.t -> Ident.t -> Typedtree.module_expr -> unit
-  val record_module_expr_use : Location.t -> Typedtree.module_expr -> unit
-*)
-(*
-  val record_include :
-    Location.t -> Typedtree.module_expr -> (* Types.signature -> *) unit
-  val record_include_sig :
-    Location.t -> Typedtree.module_type -> Types.signature -> unit
-  val record_module_type_def : Location.t -> Ident.t -> Typedtree.module_type -> unit
-*)
-
-  val record_structure : Typedtree.structure -> (Location.t * t) list
-  val record_signature : Typedtree.signature -> (Location.t * t) list
+  val record_structure : Typedtree.structure -> (Location.t, int * t list) Hashtbl.t
+  val record_signature : Typedtree.signature -> (Location.t, int * t list) Hashtbl.t
 
   val format : Format.formatter -> t -> unit
   val summary : Format.formatter -> t -> unit
 end
 
 module Tree : sig
-  type elem = Annot.t Regioned.t
+  type elem = Annot.t list Regioned.t
   type t
   val empty : t
   val is_empty : t -> bool
   path           : string; (** source path. If packed, the .cmo itself *)
   flat           : Abstraction.structure;
   top            : Abstraction.structure;
-  id_def_regions : (Ident.t, Region.t) Hashtbl.t;
-  rannots        : Annot.t Regioned.t list;
+  id_def_regions : (Ident.t, Region.t) Hashtbl.t lazy_t;
+  rannots        : Annot.t list Regioned.t list lazy_t;
   tree           : Tree.t lazy_t
 }
 
         in
         Abstraction.AStr_module (Ident.create modname (* stamp is bogus *),
                                  Abstraction.AMod_packed fullpath)) files),
-      []
+      (Hashtbl.create 1 (* empty *))
   | Partial_implementation _parts | Partial_interface _parts -> assert false
 
 let abstraction_of_cmt cmt = 
   try abstraction_of_cmt cmt with e -> 
-    Format.eprintf "AXXX %s@." (Printexc.to_string e);
+    Format.eprintf "Aiee %s@." (Printexc.to_string e);
     raise e
 
 module Make(Spotconfig : Spotconfig_intf.S) = struct
       Debug.format "cmt loading from %s@." path;
       match load_cmt_file path with
       | Some cmt -> 
+          (* CR jfuruse: all things are not always required. so inefficient *)
           Debug.format "cmt loaded from %s@." path;
           Debug.format "cmt loaded now extracting things from %s ...@." path;
           let str, loc_annots = abstraction_of_cmt cmt in
           Debug.format "cmt loaded: abstraction extracted from %s@." path;
           let path = Option.default (Filename.chop_extension path ^ ".cmo") (source_path_of_cmt cmt) in
-          let rannots = List.map (fun (loc, annot) -> 
-            { Regioned.region = Region.of_parsing loc;  value = annot }) loc_annots
+          let rannots = lazy (Hashtbl.fold (fun loc (_,annots) st -> 
+            { Regioned.region = Region.of_parsing loc;  value = annots } :: st) loc_annots [])
           in
           Debug.format "cmt loaded: rannots created from %s@." path;
-          let id_def_regions_list = 
-              List.filter_map (fun (loc, annot) -> match annot with
-              | Annot.Str sitem ->
-                  begin match Abstraction.ident_of_structure_item sitem with
-                  | None -> None
-                  | Some (_kind, id) -> 
-                      Some (id, Region.of_parsing loc)
-                  end
-              | _ -> None) loc_annots
+          let id_def_regions = lazy (
+            let tbl = Hashtbl.create 1023 in
+            Hashtbl.iter (fun loc (_,annots) ->
+              List.iter (function
+                | Annot.Str sitem ->
+                    Option.iter (Abstraction.ident_of_structure_item sitem) ~f:(fun (_kind, id) ->
+                      Hashtbl.add tbl id (Region.of_parsing loc))
+                | _ -> ()) annots) loc_annots;
+            tbl)
           in
-          let id_def_regions = Hashtbl.of_list 1023 id_def_regions_list in
           Debug.format "cmt loaded: id_def_regions created from %s@." path;
           let tree = lazy begin
-            List.fold_left Tree.add Tree.empty rannots
+            Hashtbl.fold (fun loc (_, annots) st ->
+              Tree.add st { Regioned.region = Region.of_parsing loc; value = annots })
+              loc_annots Tree.empty 
           end in
           (* CR jfuruse: it is almost the same as id_def_regions_list *)
-          let flat = List.filter_map (fun (_loc, annot) -> match annot with
+          let flat = Hashtbl.fold (fun _loc (_, annots) st -> 
+            List.filter_map (function
               | Annot.Str sitem -> Some sitem
-              | _ -> None) loc_annots
+              | _ -> None) annots @ st) loc_annots []
           in
           Debug.format "cmt loaded: flat created from %s@." path;
           Debug.format "cmt analysis done from %s@." path;
           | None -> File_itself (* the whole file *)
           | Some id -> 
               Found_at begin try
-                Hashtbl.find file.id_def_regions id
+                Hashtbl.find !!(file.id_def_regions) id
               with
               | Not_found ->
                   eprintf "Error: find location of id %a failed@."

File spotfile.mli

   path           : string; (** cmt file itself if packed *)
   flat           : Abstraction.structure;
   top            : Abstraction.structure;
-  id_def_regions : (Ident.t, Region.t) Utils.Hashtbl.t;
-  rannots        : Annot.t Regioned.t list;
+  id_def_regions : (Ident.t, Region.t) Hashtbl.t lazy_t;
+  rannots        : Annot.t list Regioned.t list lazy_t;
   tree           : Tree.t lazy_t
 }
 
 val source_path_of_cmt : cmt_infos -> string option
 val dump_file : file -> unit
 val cmt_of_file : string -> string
-val abstraction_of_cmt : cmt_infos -> Abstraction.structure * (Location.t * Annot.t) list
+val abstraction_of_cmt : cmt_infos -> Abstraction.structure * (Location.t, (int (* CR jfuruse: useless *) * Annot.t list)) Hashtbl.t
 
 module Make(Spotconfig : Spotconfig_intf.S) : sig
   module Load : sig