camlspotter avatar camlspotter committed fdc16af

working on non functional lazy in env.ml

Comments (0)

Files changed (6)

driver/compile.ml

     if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
     let sg = Typemod.transl_signature (initial_env()) ast in
     Spot.Top.record_signature sg;
+    Spot.Saved.set (Spot.Saved.Signature sg);
     if !Clflags.print_types then
       fprintf std_formatter "%a@." Printtyp.signature
                                    (Typemod.simplify_signature sg);
   | Env_cltype of summary * Ident.t * cltype_declaration
   | Env_open of summary * Path.t
 
+module XLazy : sig 
+  type ('param, 'result) t
+  val create : 'param -> ('param, 'result) t
+  val force : ('param -> 'result) -> ('param, 'result) t -> 'result
+end = struct
+  type ('param, 'result) desc = 
+    | Done of 'result
+    | Not_yet of 'param
+    | Exception of exn
+  type ('param, 'result) t = ('param, 'result) desc ref
+  let create param = ref (Not_yet param)
+  let force compute = function
+    | { contents = Done res } -> res
+    | { contents = Exception exn } -> raise exn
+    | ({ contents = Not_yet param } as t) ->
+        try
+          let res = compute param in
+          t := Done res;
+          res
+        with
+        | exn -> 
+            t := Exception exn;
+            raise exn
+end
+
 type t = {
   values: (Path.t * value_description) Ident.tbl;
   annotations: (Path.t * Annot.ident) Ident.tbl;
   summary: summary
 }
 
-and module_components = module_components_repr Lazy.t
+and module_components = (t * Subst.t * Path.t * Types.module_type,
+                         module_components_repr) XLazy.t
 
 and module_components_repr =
     Structure_comps of structure_components
   mutable comp_constrs: (string, (constructor_description * int)) Tbl.t;
   mutable comp_labels: (string, (label_description * int)) Tbl.t;
   mutable comp_types: (string, (type_declaration * int)) Tbl.t;
-  mutable comp_modules: (string, (module_type Lazy.t * int)) Tbl.t;
+  mutable comp_modules: (string, ((Subst.t * module_type, module_type) XLazy.t * int)) Tbl.t;
   mutable comp_modtypes: (string, (modtype_declaration * int)) Tbl.t;
   mutable comp_components: (string, (module_components * int)) Tbl.t;
   mutable comp_classes: (string, (class_declaration * int)) Tbl.t;
 (* Forward declarations *)
 
 let components_of_module' =
-  ref ((fun env sub path mty -> assert false) :
-          t -> Subst.t -> Path.t -> module_type -> module_components)
+  ref ((fun (env, sub, path, mty) -> assert false) :
+          (t * Subst.t * Path.t * module_type) -> module_components)
 let components_of_functor_appl' =
   ref ((fun f p1 p2 -> assert false) :
           functor_components -> Path.t -> Path.t -> module_components)
     let flags = input_value ic in
     close_in ic;
     let comps =
-      !components_of_module' empty Subst.identity
-                             (Pident(Ident.create_persistent name))
-                             (Tmty_signature sign) in
+      !components_of_module' (empty, Subst.identity,
+                              (Pident(Ident.create_persistent name)),
+                              (Tmty_signature sign)) in
     let ps = { ps_name = name;
                ps_sig = sign;
                ps_comps = comps;
 
 (* Compute structure descriptions *)
 
-let rec components_of_module env sub path mty =
+let rec components_of_module env sub path mty = XLazy.create (env, sub, path, mty)
+
+(*
   lazy(match scrape_modtype mty env with
     Tmty_signature sg ->
       let c =
               Tbl.add (Ident.name id) (cstr, !pos) c.comp_constrs;
             incr pos
         | Tsig_module(id, mty, _) ->
-            let mty' = lazy (Subst.modtype sub mty) in
+            let mty' = XLazy.create (Subst.modtype sub mty) in
             c.comp_modules <-
               Tbl.add (Ident.name id) (mty', !pos) c.comp_modules;
             let comps = components_of_module !env sub path mty in
           comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
           comp_components = Tbl.empty; comp_classes = Tbl.empty;
           comp_cltypes = Tbl.empty })
+*)
 
 (* Insertion of bindings by identifier + path *)
 
 
 let magic_number = "OCamlSpot"
 let ocaml_version = "3.12.1"
-let version = "1.3.0"
+let version = "2.0.0"
 
 module Location_bound = struct
   open Location
   let recorded () = !recorded
 end
 
+module Saved : sig
+  open Types
+  open Typedtree
+
+  type t = 
+    | Structure of structure
+    | Structure_item of structure_item
+    | Signature of signature
+    | Signature_item of signature_item
+    | Expression of expression
+    | Module_type of module_type
+    | Pattern of pattern
+    | Class_expr of class_expr
+
+  val add : t -> unit
+  val set : t -> unit
+  val get : unit -> t list * bool
+  val clear : unit -> unit
+end = struct
+  open Types
+  open Typedtree
+
+  type t = 
+    | Structure of structure
+    | Structure_item of structure_item
+    | Signature of signature
+    | Signature_item of signature_item
+    | Expression of expression
+    | Module_type of module_type
+    | Pattern of pattern
+    | Class_expr of class_expr
+
+  let saved = ref ([] : t list)
+  let successful = ref false
+
+  let add t = saved := t :: !saved
+  let set t = saved := [t]; successful := true
+  let get () = !saved, !successful
+  let clear () = saved := []
+end
+
 (* Spot file *)
 module File = struct
   (* not record but list for future exetensibility *)
     | Load_paths of string list
     | Top of Abstraction.structure option
     | Annots of (Location.t * Annot.t) list
+    | Saved of Saved.t list * bool
 
   (* marshalled type *)
   type t = elem list
           Cwd (Sys.getcwd ());
 	  Load_paths !Config.load_path;
           Top implementation;
-	  Annots annots ]
+	  Annots annots;
+          let saved, noerr = Saved.get () in Saved (saved, noerr)]
         [] (* keep sharing *))
       ()
 
     Top.clear ();
     Annot.clear ();
     Abstraction.Module_expr.Table.clear Abstraction.cache_module_expr;
-    Abstraction.Structure_item.Table.clear Abstraction.cache_structure_item
+    Abstraction.Structure_item.Table.clear Abstraction.cache_structure_item;
+    Saved.clear ()
       
   let dump ~source spot_file =
     if !Clflags.annotations then 
 
   let set_argv argv = argv_override := Some argv
 end
+
   val recorded : unit -> Abstraction.structure option
 end
 
+module Saved : sig
+  open Types
+  open Typedtree
+
+  type t = 
+    | Structure of structure
+    | Structure_item of structure_item
+    | Signature of signature
+    | Signature_item of signature_item
+    | Expression of expression
+    | Module_type of module_type
+    | Pattern of pattern
+    | Class_expr of class_expr
+
+  val add : t -> unit
+  val set : t -> unit
+  val get : unit -> t list * bool
+  val clear : unit -> unit
+end
+
 (* Spot file *)
 module File : sig
   type elem =
     | Load_paths of string list
     | Top of Abstraction.structure option
     | Annots of (Location.t * Annot.t) list
+    | Saved of Saved.t list * bool
 
   (* marshalled type *)
   type t = elem list

typing/typecore.ml

 let re node =
   Stypes.record (Stypes.Ti_expr node);
   Spot.Annot.record node.exp_loc (Spot.Annot.Type node.exp_type);
+  Spot.Saved.add (Spot.Saved.Expression node);
   node
 ;;
 let rp node =
   Stypes.record (Stypes.Ti_pat node);
   Spot.Annot.record node.pat_loc (Spot.Annot.Type node.pat_type);
+  Spot.Saved.add (Spot.Saved.Pattern node);
   node
 ;;
 

typing/typemod.ml

   path
 
 let rec transl_modtype env smty =
+  let mty = transl_modtype_ env smty in
+  Spot.Saved.add (Spot.Saved.Module_type mty);
+  mty
+
+and transl_modtype_ env smty =
   match smty.pmty_desc with
     Pmty_ident lid ->
       Tmty_ident (transl_modtype_longident smty.pmty_loc env lid)
   let type_names = ref StringSet.empty
   and module_names = ref StringSet.empty
   and modtype_names = ref StringSet.empty in
+  let save item = Spot.Saved.add (Spot.Saved.Signature_item item) in
   let rec transl_sig env sg =
     Ctype.init_def(Ident.current_time());
     match sg with
               (Spot.Annot.Str (Spot.Abstraction.Str_value id));
             Spot.Annot.record item.psig_loc
               (Spot.Annot.Type desc.val_type);
+            save (Tsig_value (id, desc));
 	    (* CR jfuruse : or, (Spot.Annot.Use (Spot.Kind.Value, ...)) ?? *) 
             let rem = transl_sig newenv srem in
             if List.exists (Ident.equal id) (get_values rem) then rem
 	        let loc = sdecl.Parsetree.ptype_loc in
 	        Spot.Annot.record loc (Spot.Annot.Str (Spot.Abstraction.Str_type id))
               with Not_found -> () (* #row type *)) decls;
+            List.iter save
+              (map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls []);
             let rem = transl_sig newenv srem in
             map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem
         | Psig_exception(name, sarg) ->
             let (id, newenv) = Env.enter_exception name arg env in
 	    Spot.Annot.record item.psig_loc 
 	      (Spot.Annot.Str (Spot.Abstraction.Str_exception id));
+            save (Tsig_exception(id, arg));
             let rem = transl_sig newenv srem in
             Tsig_exception(id, arg) :: rem
         | Psig_module(name, smty) ->
             let (id, newenv) = Env.enter_module name mty env in
 	    (* CR jfuruse: this should be module_expr_def equiv *)
             Spot.Annot.record_module_type_def item.psig_loc id mty;
+            save (Tsig_module(id, mty, Trec_not));
             let rem = transl_sig newenv srem in
             Tsig_module(id, mty, Trec_not) :: rem
         | Psig_recmodule sdecls ->
 		Spot.Annot.record_module_type_def sdecl.pmty_loc id mty
 	      with
 	      | Not_found -> ()) decls;
+            List.iter save
+              (map_rec (fun rs (id, mty) -> Tsig_module(id, mty, rs)) decls []);
             let rem = transl_sig newenv srem in
             map_rec (fun rs (id, mty) -> Tsig_module(id, mty, rs)) decls rem
         | Psig_modtype(name, sinfo) ->
 			  (id, 
 			  Spot.Abstraction.Mod_abstract)))
 	    end;
+            save (Tsig_modtype(id, info));
             let rem = transl_sig newenv srem in
             Tsig_modtype(id, info) :: rem
         | Psig_open lid ->
 	      mty sg;
             let newenv = Env.add_signature sg env in
             let rem = transl_sig newenv srem in
-            remove_values (get_values rem) sg @ rem
+            let items = remove_values (get_values rem) sg in
+            List.iter save items;
+            items @ rem
         | Psig_class cl ->
             List.iter
               (fun {pci_name = name} ->
                  check "type" item.psig_loc type_names name)
               cl;
             let (classes, newenv) = Typeclass.class_descriptions env cl in
+            List.iter (List.iter save)
+              (map_rec
+                 (fun rs (i, d, i', d', i'', d'', i''', d''', _, _, _) ->
+                    [Tsig_class(i, d, rs);
+                     Tsig_cltype(i', d', rs);
+                     Tsig_type(i'', d'', rs);
+                     Tsig_type(i''', d''', rs)])
+                 classes []);
             let rem = transl_sig newenv srem in
             List.flatten
               (map_rec
                  check "type" item.psig_loc type_names name)
               cl;
             let (classes, newenv) = Typeclass.class_type_declarations env cl in
+            List.iter (List.iter save)
+              (map_rec
+                 (fun rs (i, d, i', d', i'', d'') ->
+                    [Tsig_cltype(i, d, rs);
+                     Tsig_type(i', d', rs);
+                     Tsig_type(i'', d'', rs)])
+                 classes []);
             let rem = transl_sig newenv srem in
             List.flatten
               (map_rec
                      Tsig_type(i', d', rs);
                      Tsig_type(i'', d'', rs)])
                  classes [rem])
-    in transl_sig env sg
+    in 
+  let sg = transl_sig env sg in
+  Spot.Saved.add (Spot.Saved.Signature sg);
+  sg
 
 and transl_modtype_info env sinfo =
   match sinfo with
   let type_names = ref StringSet.empty
   and module_names = ref StringSet.empty
   and modtype_names = ref StringSet.empty in
+  let save item = Spot.Saved.add (Spot.Saved.Structure_item item) in
   let rec type_struct env sstr =
     Ctype.init_def(Ident.current_time());
     match sstr with
         ([], [], env)
     | {pstr_desc = Pstr_eval sexpr} :: srem ->
         let expr = Typecore.type_expression env sexpr in
+        save (Tstr_eval expr);
         let (str_rem, sig_rem, final_env) = type_struct env srem in
         (Tstr_eval expr :: str_rem, sig_rem, final_env)
     | {pstr_desc = Pstr_value(rec_flag, sdefs); pstr_loc = loc} :: srem ->
         in
         let (defs, newenv) =
           Typecore.type_binding env rec_flag sdefs scope in
+        save (Tstr_value(rec_flag, defs));
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
         let bound_idents = let_bound_idents defs in
         let make_sig_value id =
         let desc = Typedecl.transl_value_decl env sdesc in
         let (id, newenv) = Env.enter_value name desc env in
 	Spot.Annot.record loc (Spot.Annot.Str (Spot.Abstraction.Str_value id));
+        save (Tstr_primitive(id, desc));
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
         (Tstr_primitive(id, desc) :: str_rem,
          Tsig_value(id, desc) :: sig_rem,
           (fun (name, decl) -> check "type" loc type_names name)
           sdecls;
         let (decls, newenv) = Typedecl.transl_type_decl env sdecls in
+        save (Tstr_type decls);
         let newenv' =
           enrich_type_decls anchor decls env newenv in
         (* Sometimes, [List.length sdecls <> List.length decls] due to
     | {pstr_desc = Pstr_exception(name, sarg); pstr_loc = loc} :: srem ->
         let arg = Typedecl.transl_exception env sarg in
         let (id, newenv) = Env.enter_exception name arg env in
+        save (Tstr_exception(id, arg));
 	Spot.Annot.record loc (Spot.Annot.Str (Spot.Abstraction.Str_exception id));
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
         (Tstr_exception(id, arg) :: str_rem,
         (* CR jfuruse: loc is bit incorrect but no better one *)
         Spot.Annot.record loc (Spot.Annot.Use (Spot.Kind.Exception, path));
         let (id, newenv) = Env.enter_exception name arg env in
+        save (Tstr_exn_rebind(id, path));
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
         (Tstr_exn_rebind(id, path) :: str_rem,
          Tsig_exception(id, arg) :: sig_rem,
         let (id, newenv) = Env.enter_module name mty env in
 	(* CRv2 jfuruse: pos for name? *)
 	Spot.Annot.record_module_expr_def loc id modl;
+        save (Tstr_module(id, modl));
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
         (Tstr_module(id, modl) :: str_rem,
          Tsig_module(id, modl.mod_type, Trec_not) :: sig_rem,
 	  Spot.Annot.record_module_expr_def modl.mod_loc id modl) bindings1;
         let bindings2 =
           check_recmodule_inclusion newenv bindings1 in
+        save (Tstr_recmodule bindings2);
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
         (Tstr_recmodule bindings2 :: str_rem,
          map_rec (fun rs (id, modl) -> Tsig_module(id, modl.mod_type, rs))
         let mty = transl_modtype env smty in
         let (id, newenv) = Env.enter_modtype name (Tmodtype_manifest mty) env in
 	Spot.Annot.record_module_type_def loc id mty;
+        save (Tstr_modtype(id, mty));
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
         (Tstr_modtype(id, mty) :: str_rem,
          Tsig_modtype(id, Tmodtype_manifest mty) :: sig_rem,
            (fun {pci_name = name} -> check "type" loc type_names name)
            cl;
         let (classes, new_env) = Typeclass.class_declarations env cl in
+        List.iter save [
+          Tstr_class
+            (List.map (fun (i, d, _,_,_,_,_,_, s, m, c) ->
+              let vf = if d.cty_new = None then Virtual else Concrete in
+              (i, s, m, c, vf)) classes);
+          Tstr_cltype
+            (List.map (fun (_,_, i, d, _,_,_,_,_,_,_) -> (i, d)) classes);
+          Tstr_type
+            (List.map (fun (_,_,_,_, i, d, _,_,_,_,_) -> (i, d)) classes);
+          Tstr_type
+            (List.map (fun (_,_,_,_,_,_, i, d, _,_,_) -> (i, d)) classes)];
         let (str_rem, sig_rem, final_env) = type_struct new_env srem in
         (Tstr_class
            (List.map (fun (i, d, _,_,_,_,_,_, s, m, c) ->
           (fun {pci_name = name} -> check "type" loc type_names name)
           cl;
         let (classes, new_env) = Typeclass.class_type_declarations env cl in
+        List.iter save [
+          Tstr_cltype
+            (List.map (fun (i, d, _, _, _, _) -> (i, d)) classes);
+          Tstr_type
+            (List.map (fun (_, _, i, d, _, _) -> (i, d)) classes);
+          Tstr_type
+            (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes)]; 
         let (str_rem, sig_rem, final_env) = type_struct new_env srem in
         (Tstr_cltype
            (List.map (fun (i, d, _, _, _, _) -> (i, d)) classes) ::
         Spot.Annot.record_include loc modl sg;
         List.iter
           (check_sig_item type_names module_names modtype_names loc) sg;
+        save (Tstr_include (modl, bound_value_identifiers sg, sg)); 
         let new_env = Env.add_signature sg env in
         let (str_rem, sig_rem, final_env) = type_struct new_env srem in
         (Tstr_include (modl, bound_value_identifiers sg, sg) :: str_rem,
   let simple_sg = simplify_signature sg in
   Typecore.force_delayed_checks ();
   Spot.Top.record_structure str;
+  Spot.Saved.set (Spot.Saved.Structure str); 
   if !Clflags.print_types then begin
     fprintf std_formatter "%a@." Printtyp.signature simple_sg;
     (str, Tcoerce_none)   (* result is ignored by Compile.implementation *)
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.