Commits

camlspotter committed 1a66287

updates

Comments (0)

Files changed (8)

 spot.cmi :
 spotconfig.cmi : spotconfig_intf.cmo
 spoteval.cmi : utils.cmi spot.cmi
-spotfile.cmi : utils.cmi spoteval.cmi spotconfig_intf.cmo spot.cmi
+spotfile.cmi : spoteval.cmi spotconfig_intf.cmo spot.cmi
 treeset.cmi : xset.cmi
 ttfold.cmi :
 typeFix.cmi :
 xpath.cmi : name.cmi
 xprinttyp.cmi :
 xset.cmi :
+checksum.cmo :
+checksum.cmx :
 command.cmo : command.cmi
 command.cmx : command.cmi
-dotfile.cmo :
-dotfile.cmx :
+dotfile.cmo : utils.cmi
+dotfile.cmx : utils.cmx
 ext.cmo : xprinttyp.cmi xpath.cmi xlongident.cmi xident.cmi
 ext.cmx : xprinttyp.cmx xpath.cmx xlongident.cmx xident.cmx
 locident.cmo : locident.cmi
     spotconfig.cmx spot.cmx pathreparse.cmx ext.cmx command.cmx
 pathreparse.cmo : utils.cmi spot.cmi locident.cmi ext.cmo pathreparse.cmi
 pathreparse.cmx : utils.cmx spot.cmx locident.cmx ext.cmx pathreparse.cmi
-spot.cmo : utils.cmi ttfold.cmi treeset.cmi ext.cmo spot.cmi
-spot.cmx : utils.cmx ttfold.cmx treeset.cmx ext.cmx spot.cmi
+spot.cmo : utils.cmi ttfold.cmi treeset.cmi ext.cmo checksum.cmo spot.cmi
+spot.cmx : utils.cmx ttfold.cmx treeset.cmx ext.cmx checksum.cmx spot.cmi
 spotconfig.cmo : utils.cmi spot.cmi ext.cmo spotconfig.cmi
 spotconfig.cmx : utils.cmx spot.cmx ext.cmx spotconfig.cmi
 spotconfig_intf.cmo : spot.cmi ext.cmo
 treeset.cmx : xset.cmx treeset.cmi
 ttfold.cmo : ttfold.cmi
 ttfold.cmx : ttfold.cmi
-ttfold.out.cmo :
-ttfold.out.cmx :
 typeFix.cmo : utils.cmi name.cmi typeFix.cmi
 typeFix.cmx : utils.cmx name.cmx typeFix.cmi
 typedtreefold.cmo :
 typeexpand.cmx : utils.cmx typeexpand.cmi
 utils.cmo : utils.cmi
 utils.cmx : utils.cmi
-x.cmo :
-x.cmx :
 xident.cmo : name.cmi xident.cmi
 xident.cmx : name.cmx xident.cmi
 xlongident.cmo : xlongident.cmi
 # Requires unix!
 COMPFLAGS= $(INCLUDES_DEP) -I +unix
 
-MODULES= utils dotfile xset treeset command typeexpand \
-	xlongident name xident xpath locident typeFix xprinttyp ext ttfold spot spoteval spotconfig_intf spotconfig spotfile pathreparse ocamlspot
+MODULES= utils checksum dotfile xset treeset command typeexpand \
+	xlongident name xident xpath locident typeFix xprinttyp ext ttfold cmt spot spoteval spotconfig_intf spotconfig spotfile pathreparse ocamlspot
 
 OBJS=		$(addsuffix .cmo, $(MODULES))
 
   include Spotfile.Make(C)
 end
 
-open Cmt_format
-
 module SAbs = Spot.Abstraction
 
 module Dump = struct
   (* mainly debugging purpose *)
 
-  let file = File.dump_file
+  let file = File.dump
 
   let rannots_full file = 
     eprintf "@[<2>rannots =@ [ @[<v>%a@]@] ]@."
   ;;
 
   let info path =
-    let file = load (File.cmt_of_file path) in
+    let file = load (File.Cmt.of_path path) in
     printf "Compile: %s@."
       (String.concat " " 
          (List.map Command.escaped_for_shell 
-            (Array.to_list file.File.cmt.cmt_args)));
+            (Array.to_list file.File.args)));
     printf "@[<v2>Included_dirs:@ %a@]@."
       (Format.list "" pp_print_string)
-      file.File.cmt.cmt_loadpath
+      file.File.loadpath
 
   let query_by_kind_path file kind path = 
     try Some (File.find_path_in_flat file (kind, path)) with Not_found -> None
           match List.filter (function Annot.Type _ -> true | _ -> false) annots with
           (* CR jfuruse: Sometimes more than one Annot.Type are found at the same place... *)
           | Annot.Type (typ, env, `Expr) :: _ -> 
-              printf "Expand: @[%a@]@." Typeexpand.format_as_expr (Typeexpand.expand file.File.cmt.cmt_loadpath env typ)
+              printf "Expand: @[%a@]@." Typeexpand.format_as_expr (Typeexpand.expand file.File.loadpath env typ)
           | Annot.Type (typ, env, `Pattern) :: _ -> 
-              printf "Expand: @[%a@]@." Typeexpand.format_as_pattern (Typeexpand.expand file.File.cmt.cmt_loadpath env typ)
+              printf "Expand: @[%a@]@." Typeexpand.format_as_pattern (Typeexpand.expand file.File.loadpath env typ)
           | Annot.Type (_typ, _env, `Val) :: _ -> ()
           | _ -> ()
         end;
     (* CR jfuruse: dup *)
     Debug.format "ocamlspot %s%s@." path (C.SearchSpec.to_string spec);
     Debug.format "cwd: %s@." (Sys.getcwd ());
-    let path = File.cmt_of_file path in
+    let path = File.Cmt.of_path path in
     let file = load path in
 
     let query_kind_path k path = print_query_result k (query_by_kind_path file k path) in
     (* CR jfuruse: dup *)
     Debug.format "ocamlspot %s%s@." path (C.SearchSpec.to_string spec);
     Debug.format "cwd: %s@." (Sys.getcwd ());
-    let path = File.cmt_of_file path in
+    let path = File.Cmt.of_path path in
     let file = load path in
 
     let find_by_kind_path k path found =
   let recheck files =
     let recheck mlpath =
       Debug.format "cwd: %s@." (Sys.getcwd ());
-      let path = File.cmt_of_file mlpath in
+      let path = File.Cmt.of_path mlpath in
       let file = File.load ~load_paths: ["."] path in
     
       printf "Compile: %s@."
 	  RAnnot.format rrspot) t
 end
 
+(* Minimum data for spotting, which are saved into spot files *)
+module File = struct
+  type t = {
+    modname        : string;
+    builddir       : string; 
+    loadpath       : string list;
+    args           : string array;
+    path           : string; (** source path. If packed, the .cmo itself *)
+    top            : Abstraction.structure;
+    loc_annots     : (Location.t, Annot.t list) Hashtbl.t
+  }
+
+  let save path t =
+    let oc = open_out_bin path in
+    output_string oc "spot";
+    output_string oc Checksum.char16;
+    output_value oc t;
+    close_out oc
+
+  let load path =
+    let ic = open_in path in
+    let buf = String.create 4 in
+    really_input ic buf 0 4;
+    if buf <> "spot" then failwithf "file %s is not a spot file" path;
+    let buf = String.create 16 in
+    really_input ic buf 0 16;
+    if buf <> Checksum.char16 then failwithf "file %s has an incompatible checksum" path;
+    let v = input_value ic in
+    close_in ic;
+    v
+
+  let of_cmt cmt =
+    let ext = if Cmt.is_opt cmt then ".cmx" else ".cmo" in
+    let path = Option.default (Filename.chop_extension path ^ ext) (Cmt.source_path cmt) in
+    { modname = cmt.cmt_modname;
+      builddir = cmt.cmt_builddir;
+      loadpath = cmt.cmt_loadpath;
+      args = cmt.cmt_args;
+      path; 
+      top;
+      loc_annots;
+    }
+end
+
+(* Spot info for each compilation unit *)
+module Unit = struct
+  type t = {
+    modname        : string;
+    builddir       : string; 
+    loadpath       : string list;
+    args           : string array;
+    path           : string; (** source path. If packed, the .cmo itself *)
+    top            : Abstraction.structure;
+
+    flat           : Abstraction.structure lazy_t;
+    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
+  }
+end
+
 open Spoteval
 open Cmt_format
 
+(*
 type file = {
-  cmt            : Cmt_format.cmt_infos;
+  modname        : string;
+  builddir       : string; 
+  loadpath       : string list;
+  args           : string array;
+  path           : string; (** source path. If packed, the .cmo itself *)
+  structure      : Spot.Abstraction.structure;
+  loc_annots     : (Location.t, Spot.Annot.t list) Hashtbl.t
+}
+*)
+
+type t = {
+  modname        : string;
+  builddir       : string; 
+  loadpath       : string list;
+  args           : string array;
   path           : string; (** source path. If packed, the .cmo itself *)
   flat           : Abstraction.structure;
   top            : Abstraction.structure;
   tree           : Tree.t lazy_t
 }
 
-let source_path_of_cmt file = match file.cmt_sourcefile with 
-  | Some f -> Some (file.cmt_builddir ^/ f)
-  | None -> None
+module Cmt = struct
 
-let dump_file file =
-  eprintf "@[<v2>{ module= %S;@ path= %S;@ source= %S;@ builddir= %S;@ loadpath= [ @[%a@] ];@ argv= [| @[%a@] |];@ ... }@]@."
-    file.cmt.cmt_modname
+  let source_path file = match file.cmt_sourcefile with 
+    | Some f -> Some (file.cmt_builddir ^/ f)
+    | None -> None
+
+  (* xxx.{ml,cmo,cmx,spot} => xxx.spot 
+     xxx.{mli,cmi,spit} => xxx.spit *)
+  let of_path path =
+    let dirname, filename =
+      try
+        let slash = String.rindex path '/' in
+        Some (String.sub path 0 slash),
+        String.sub path (slash + 1) (String.length path - slash - 1)
+      with
+      | Not_found -> None, path
+    in
+    let filename =
+      match Filename.split_extension filename with
+      | body, (".cmi" | ".mli" | ".cmti") -> body ^ ".cmti"
+      | body, _ -> body ^ ".cmt"
+    in
+    match dirname with
+    | None -> filename
+    | Some d -> d ^/ filename
+
+    (* CR jfuruse: this is a dirty workaround. It should be nice if we could know cmt is created by opt or byte *)          
+    let is_opt cmt = 
+      List.exists (fun x -> match Filename.split_extension x with (_, ".cmx") -> true | _ -> false) (Array.to_list cmt.cmt_args)
+
+  let abstraction cmt = match cmt.cmt_annots with
+    | Implementation str -> 
+        let loc_annots = Spot.Annot.record_structure str in
+        begin match Abstraction.structure str with
+        | Abstraction.AMod_structure str -> str, loc_annots
+        | _ -> assert false
+        end
+    | Interface sg -> 
+        let loc_annots = Spot.Annot.record_signature sg in
+        begin match Abstraction.signature sg with
+        | Abstraction.AMod_structure str -> str, loc_annots
+        | _ -> assert false
+        end
+    | Packed (_sg, files) ->
+        (List.map (fun file ->
+          let fullpath = if Filename.is_relative file then cmt.cmt_builddir ^/ file else file in
+          let modname = match Filename.split_extension (Filename.basename file) with 
+            | modname, (".cmo" | ".cmx") -> String.capitalize modname
+            | _ -> assert false
+          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 cmt = 
+    try abstraction cmt with e -> 
+      Format.eprintf "Aiee %s@." (Printexc.to_string e);
+      raise e
+end
+
+let dump file =
+  eprintf "@[<v2>{ module= %S;@ path= %S;@ builddir= %S;@ loadpath= [ @[%a@] ];@ argv= [| @[%a@] |];@ ... }@]@."
+    file.modname
     file.path
-    (match file.cmt.cmt_sourcefile with Some s -> s | None -> "???")
-    file.cmt.cmt_builddir
-    (Format.list ";@ " (fun ppf s -> fprintf ppf "%S" s)) file.cmt.cmt_loadpath
-    (Format.list ";@ " (fun ppf s -> fprintf ppf "%S" s)) (Array.to_list file.cmt.cmt_args)
-
-(* xxx.{ml,cmo,cmx,spot} => xxx.spot 
-   xxx.{mli,cmi,spit} => xxx.spit *)
-let cmt_of_file file =
-  let dirname, filename =
-    try
-      let slash = String.rindex file '/' in
-      Some (String.sub file 0 slash),
-      String.sub file (slash + 1) (String.length file - slash - 1)
-    with
-    | Not_found -> None, file
-  in
-  let filename =
-    match Filename.split_extension filename with
-    | body, (".cmi" | ".mli" | ".cmti") -> body ^ ".cmti"
-    | body, _ -> body ^ ".cmt"
-  in
-  match dirname with
-  | None -> filename
-  | Some d -> d ^/ filename
-
-let abstraction_of_cmt cmt = match cmt.cmt_annots with
-  | Implementation str -> 
-      let loc_annots = Spot.Annot.record_structure str in
-      begin match Abstraction.structure str with
-      | Abstraction.AMod_structure str -> str, loc_annots
-      | _ -> assert false
-      end
-  | Interface sg -> 
-      let loc_annots = Spot.Annot.record_signature sg in
-      begin match Abstraction.signature sg with
-      | Abstraction.AMod_structure str -> str, loc_annots
-      | _ -> assert false
-      end
-  | Packed (_sg, files) ->
-      (List.map (fun file ->
-        let fullpath = if Filename.is_relative file then cmt.cmt_builddir ^/ file else file in
-        let modname = match Filename.split_extension (Filename.basename file) with 
-          | modname, (".cmo" | ".cmx") -> String.capitalize modname
-          | _ -> assert false
-        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 "Aiee %s@." (Printexc.to_string e);
-    raise e
+    file.builddir
+    (Format.list ";@ " (fun ppf s -> fprintf ppf "%S" s)) file.loadpath
+    (Format.list ";@ " (fun ppf s -> fprintf ppf "%S" s)) (Array.to_list file.args)
 
 module Make(Spotconfig : Spotconfig_intf.S) = struct
   (* open Abstraction *)
 
   module Load : sig
     exception Old_cmt of string (* cmt *) * string (* source *)
-    val load : load_paths:string list -> string -> file
-    val load_module : ?spit:bool -> load_paths:string list -> string -> file
+    val load : load_paths:string list -> string -> t
+    val load_module : ?spit:bool -> load_paths:string list -> string -> t
   end = struct
 
     let check_time_stamp ~cmt source =
 
     let load_cmt_file file = snd (Cmt_format.read file)
 
-    let load_directly path : file =
+    let load_directly path : t =
       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
+          let top, loc_annots = Cmt.abstraction cmt in
           Debug.format "cmt loaded: abstraction extracted from %s@." path;
 
-          (* CR jfuruse: this is a dirty workaround. It should be nice if we could know cmt is created by opt or byte *)          
-          let cm_extension = 
-            if List.exists (fun x -> match Filename.split_extension x with (_, ".cmx") -> true | _ -> false) (Array.to_list cmt.cmt_args)
-            then ".cmx" else ".cmo"
-          in
-
-          let path = Option.default (Filename.chop_extension path ^ cm_extension) (source_path_of_cmt cmt) in
+          let path = Option.default (Filename.chop_extension path ^ if Cmt.is_opt cmt then ".cmx" else ".cmo") (Cmt.source_path cmt) in
           let rannots = lazy (Hashtbl.fold (fun loc (_,annots) st -> 
             { Regioned.region = Region.of_parsing loc;  value = annots } :: st) loc_annots [])
           in
           in
           Debug.format "cmt loaded: flat created from %s@." path;
           Debug.format "cmt analysis done from %s@." path;
-          { cmt; path;
-            top = str;
+          { modname  = cmt.cmt_modname;
+            builddir = cmt.cmt_builddir;
+            loadpath = cmt.cmt_loadpath;
+            args     = cmt.cmt_args;
+            path;
+            top;
             flat;
             id_def_regions;
             rannots;
 
     (* CR jfuruse: exception *)
     (* CRv2 jfuruse: add and check cache time stamp *)
-    let load_directly_with_cache : string -> file = 
+    let load_directly_with_cache : string -> t = 
       let cache = Hashtbl.create 17 in
       fun path ->
         try 
                   failwith (Printf.sprintf "failed to find cmt file %s" path)
 
     let find_in_path load_paths body ext =
-        let body_ext = body ^ ext in
+      let body_ext = body ^ ext in
       let find_in_path load_paths name = 
         try Misc.find_in_path load_paths name with Not_found ->
           Misc.find_in_path_uncap load_paths name
         | _ -> failwith (Printf.sprintf "cmt file not found: %s" body_ext)
       
 
-    let load ~load_paths cmtname : file =
+    let load ~load_paths cmtname : t =
       Debug.format "@[<2>cmt searching %s in@ paths [@[%a@]]@]@." 
           cmtname
           (Format.list "; " (fun ppf x -> fprintf ppf "%S" x)) 
       let path = find_in_path load_paths body ext in
       load_directly_with_cache path
 
-    let load ~load_paths cmtname : file =
+    let load ~load_paths cmtname : t =
       let alternate_cmtname = 
         if Filename.is_relative cmtname then None
         else
 
   let empty_env file =
     { Env.path = file.path;
-      cwd = file.cmt.cmt_builddir;
-      load_paths = file.cmt.cmt_loadpath;
+      cwd = file.builddir;
+      load_paths = file.loadpath;
       binding = Binding.empty }
 
   let invalid_env file =
     { Env.path = file.path;
-      cwd = file.cmt.cmt_builddir;
-      load_paths = file.cmt.cmt_loadpath;
+      cwd = file.builddir;
+      load_paths = file.loadpath;
       binding = Binding.invalid }
       
   type result =
       | path ->
           (* CR jfuruse: loading twice... *)
           Debug.format "Finding %a@." PIdent.format pid;
-          let file = Load.load ~load_paths:[] (cmt_of_file path) in
+          let file = Load.load ~load_paths:[] (Cmt.of_path path) in
           match pid.PIdent.ident with
           | None -> File_itself (* the whole file *)
           | Some id -> 
   let _ = Eval.str_of_global_ident := str_of_global_ident
 
   let eval_packed env file =
-    let f = Load.load ~load_paths:[""] (cmt_of_file (env.Env.cwd ^/ file)) in
+    let f = Load.load ~load_paths:[""] (Cmt.of_path (env.Env.cwd ^/ file)) in
     Value.Structure ({ PIdent.path = f.path; ident = None },
                     Eval.structure (empty_env f) f.top,
                     None (* packed has no .mli *))
 open Cmt_format
 open Spoteval
 
-type file = {
-  cmt            : Cmt_format.cmt_infos;
+type t = {
+  modname        : string;
+  builddir       : string; 
+  loadpath       : string list;
+  args           : string array;
+
   path           : string; (** cmt file itself if packed *)
   flat           : Abstraction.structure;
   top            : Abstraction.structure;
   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, (int (* CR jfuruse: useless *) * Annot.t list)) Hashtbl.t
+module Cmt : sig
+  val of_path : string -> string
+end
+
+val dump : t -> unit
 
 module Make(Spotconfig : Spotconfig_intf.S) : sig
-  module Load : sig
-    exception Old_cmt of string * string
-    val load : load_paths:string list -> string -> file
-    val load_module : ?spit:bool -> load_paths:string list -> string -> file (* CR jfuruse: spit *)
-  end
   exception Old_cmt of string * string
-  val load : load_paths:string list -> string -> file
-  val load_module : ?spit:bool -> load_paths:string list -> string -> file (* CR jfuruse: spit *)
-  val empty_env   : file -> Env.t
-  val invalid_env : file -> Env.t
+  val load : load_paths:string list -> string -> t
+  val load_module : ?spit:bool -> load_paths:string list -> string -> t (* CR jfuruse: spit *)
+
+  val empty_env   : t -> Env.t
+  val invalid_env : t -> Env.t
+
   type result = File_itself | Found_at of Region.t | Predefined
-  val find_path_in_flat : file -> Kind.t * Path.t -> PIdent.t * result
+
+  val find_path_in_flat : t -> Kind.t * Path.t -> PIdent.t * result
   val str_of_global_ident : load_paths:string list -> Ident.t -> string * Value.structure
   val eval_packed : Env.t -> string -> Value.t
 end
     | None -> ()
     | Some v -> f v
 
-  let default dv = function
-    | None -> dv
+  let default df = function
+    | None -> df ()
     | Some v -> v
 end
 
   res
 ;;
 
+let failwithf fmt = Printf.kprintf failwith fmt
+let invalid_argf fmt = Printf.kprintf invalid_arg fmt
+
 module Unix = struct
   include Unix
 
   val map : f:('a -> 'b) -> 'a option -> 'b option
   val bind : 'a option -> ('a -> 'b option) -> 'b option
   val iter : f:('a -> unit) -> 'a option -> unit
-  val default : 'a -> 'a option -> 'a 
+  val default : (unit -> 'a) -> 'a option -> 'a 
 end
 
 exception Finally of exn * exn
 
 val protect : f:('a -> 'b) -> 'a -> finally:('a -> unit) -> 'b
+val failwithf : ('a, unit, string, 'b) format4 -> 'a
+val invalid_argf : ('a, unit, string, 'b) format4 -> 'a
 
 module Unix : sig
   include module type of Unix