Commits

camlspotter committed e5a9ba0

removed lazy closures from env for spot

Comments (0)

Files changed (1)

 module XLazy : sig 
   type ('param, 'result) t
   val create : 'param -> ('param, 'result) t
+  val create_from_result : 'result -> ('param, 'result) t
   val force : ('param -> 'result) -> ('param, 'result) t -> 'result
 end = struct
   type ('param, 'result) desc = 
     | Exception of exn
   type ('param, 'result) t = ('param, 'result) desc ref
   let create param = ref (Not_yet param)
+  let create_from_result result = ref (Done result)
   let force compute = function
     | { contents = Done res } -> res
     | { contents = Exception exn } -> raise exn
   ref ((fun env mty1 path1 mty2 -> assert false) :
           t -> module_type -> Path.t -> module_type -> unit)
 
+let force_components_of_module' = ref (fun _ -> assert false : module_components -> module_components_repr)
+let force_subst_modtype' = ref (fun _ -> assert false : (Subst.t * module_type, module_type) XLazy.t -> module_type)
+
 (* The name of the compilation unit currently compiled.
    "" if outside a compilation unit. *)
 
         else raise Not_found
       end
   | Pdot(p, s, pos) ->
-      begin match Lazy.force(find_module_descr p env) with
+      begin match !force_components_of_module'(find_module_descr p env) with
         Structure_comps c ->
           let (descr, pos) = Tbl.find s c.comp_components in
           descr
          raise Not_found
       end
   | Papply(p1, p2) ->
-      begin match Lazy.force(find_module_descr p1 env) with
+      begin match !force_components_of_module'(find_module_descr p1 env) with
         Functor_comps f ->
           !components_of_functor_appl' f p1 p2
       | Structure_comps c ->
       let (p, data) = Ident.find_same id (proj1 env)
       in data
   | Pdot(p, s, pos) ->
-      begin match Lazy.force(find_module_descr p env) with
+      begin match !force_components_of_module'(find_module_descr p env) with
         Structure_comps c ->
           let (data, pos) = Tbl.find s (proj2 c) in data
       | Functor_comps f ->
         else raise Not_found
       end
   | Pdot(p, s, pos) ->
-      begin match Lazy.force (find_module_descr p env) with
+      begin match !force_components_of_module' (find_module_descr p env) with
         Structure_comps c ->
-          let (data, pos) = Tbl.find s c.comp_modules in Lazy.force data
+          let (data, pos) = Tbl.find s c.comp_modules in !force_subst_modtype' data
       | Functor_comps f ->
           raise Not_found
       end
       end
   | Ldot(l, s) ->
       let (p, descr) = lookup_module_descr l env in
-      begin match Lazy.force descr with
+      begin match !force_components_of_module' descr with
         Structure_comps c ->
           let (descr, pos) = Tbl.find s c.comp_components in
           (Pdot(p, s, pos), descr)
   | Lapply(l1, l2) ->
       let (p1, desc1) = lookup_module_descr l1 env in
       let (p2, mty2) = lookup_module l2 env in
-      begin match Lazy.force desc1 with
+      begin match !force_components_of_module' desc1 with
         Functor_comps f ->
           !check_modtype_inclusion env mty2 p2 f.fcomp_arg;
           (Papply(p1, p2), !components_of_functor_appl' f p1 p2)
       end
   | Ldot(l, s) ->
       let (p, descr) = lookup_module_descr l env in
-      begin match Lazy.force descr with
+      begin match !force_components_of_module' descr with
         Structure_comps c ->
           let (data, pos) = Tbl.find s c.comp_modules in
-          (Pdot(p, s, pos), Lazy.force data)
+          (Pdot(p, s, pos), !force_subst_modtype' data)
       | Functor_comps f ->
           raise Not_found
       end
       let (p1, desc1) = lookup_module_descr l1 env in
       let (p2, mty2) = lookup_module l2 env in
       let p = Papply(p1, p2) in
-      begin match Lazy.force desc1 with
+      begin match !force_components_of_module' desc1 with
         Functor_comps f ->
           !check_modtype_inclusion env mty2 p2 f.fcomp_arg;
           (p, Subst.modtype (Subst.add_module f.fcomp_param p2 f.fcomp_subst)
       Ident.find_name s (proj1 env)
   | Ldot(l, s) ->
       let (p, desc) = lookup_module_descr l env in
-      begin match Lazy.force desc with
+      begin match !force_components_of_module' desc with
         Structure_comps c ->
           let (data, pos) = Tbl.find s (proj2 c) in
           (Pdot(p, s, pos), data)
       Ident.find_name s (proj1 env)
   | Ldot(l, s) ->
       let (p, desc) = lookup_module_descr l env in
-      begin match Lazy.force desc with
+      begin match !force_components_of_module' desc with
         Structure_comps c ->
           let (data, pos) = Tbl.find s (proj2 c) in
           data
 
 (* Compute structure descriptions *)
 
-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 =
-        { comp_values = Tbl.empty; comp_annotations = Tbl.empty;
-          comp_constrs = Tbl.empty;
-          comp_labels = Tbl.empty; comp_types = Tbl.empty;
-          comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
-          comp_components = Tbl.empty; comp_classes = Tbl.empty;
-          comp_cltypes = Tbl.empty } in
-      let (pl, sub) = prefix_idents path 0 sub sg in
-      let env = ref env in
-      let pos = ref 0 in
-      List.iter2 (fun item path ->
-        match item with
-          Tsig_value(id, decl) ->
-            let decl' = Subst.value_description sub decl in
-            c.comp_values <-
-              Tbl.add (Ident.name id) (decl', !pos) c.comp_values;
-            if !Clflags.annotations then begin
-              c.comp_annotations <-
-                Tbl.add (Ident.name id) (Annot.Iref_external, !pos)
-                        c.comp_annotations;
-            end;
-            begin match decl.val_kind with
-              Val_prim _ -> () | _ -> incr pos
-            end
-        | Tsig_type(id, decl, _) ->
-            let decl' = Subst.type_declaration sub decl in
-            c.comp_types <-
-              Tbl.add (Ident.name id) (decl', nopos) c.comp_types;
-            List.iter
-              (fun (name, descr) ->
-                c.comp_constrs <- Tbl.add name (descr, nopos) c.comp_constrs)
-              (constructors_of_type path decl');
-            List.iter
-              (fun (name, descr) ->
-                c.comp_labels <- Tbl.add name (descr, nopos) c.comp_labels)
-              (labels_of_type path decl');
-            env := store_type_infos id path decl !env
-        | Tsig_exception(id, decl) ->
-            let decl' = Subst.exception_declaration sub decl in
-            let cstr = Datarepr.exception_descr path decl' in
-            c.comp_constrs <-
-              Tbl.add (Ident.name id) (cstr, !pos) c.comp_constrs;
-            incr pos
-        | Tsig_module(id, mty, _) ->
-            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
-            c.comp_components <-
-              Tbl.add (Ident.name id) (comps, !pos) c.comp_components;
-            env := store_module id path mty !env;
-            incr pos
-        | Tsig_modtype(id, decl) ->
-            let decl' = Subst.modtype_declaration sub decl in
-            c.comp_modtypes <-
-              Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes;
-            env := store_modtype id path decl !env
-        | Tsig_class(id, decl, _) ->
-            let decl' = Subst.class_declaration sub decl in
-            c.comp_classes <-
-              Tbl.add (Ident.name id) (decl', !pos) c.comp_classes;
-            incr pos
-        | Tsig_cltype(id, decl, _) ->
-            let decl' = Subst.cltype_declaration sub decl in
-            c.comp_cltypes <-
-              Tbl.add (Ident.name id) (decl', !pos) c.comp_cltypes)
-        sg pl;
-        Structure_comps c
-  | Tmty_functor(param, ty_arg, ty_res) ->
-        Functor_comps {
-          fcomp_param = param;
-          (* fcomp_arg must be prefixed eagerly, because it is interpreted
-             in the outer environment, not in env *)
-          fcomp_arg = Subst.modtype sub ty_arg;
-          (* fcomp_res is prefixed lazily, because it is interpreted in env *)
-          fcomp_res = ty_res;
-          fcomp_env = env;
-          fcomp_subst = sub;
-          fcomp_cache = Hashtbl.create 17 }
-  | Tmty_ident p ->
-        Structure_comps {
-          comp_values = Tbl.empty; comp_annotations = Tbl.empty;
-          comp_constrs = Tbl.empty;
-          comp_labels = Tbl.empty; comp_types = Tbl.empty;
-          comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
-          comp_components = Tbl.empty; comp_classes = Tbl.empty;
-          comp_cltypes = Tbl.empty })
-*)
+let components_of_module env sub path mty : module_components = XLazy.create (env, sub, path, mty)
 
 (* Insertion of bindings by identifier + path *)
 
-and store_value id path decl env =
+let rec store_value id path decl env =
   { env with
     values = Ident.add id (path, decl) env.values;
     summary = Env_value(env.summary, id, decl) }
     cltypes = Ident.add id (path, desc) env.cltypes;
     summary = Env_cltype(env.summary, id, desc) }
 
+let force_components_of_module = XLazy.force (fun (env, sub, path, mty) ->
+  match scrape_modtype mty env with
+    Tmty_signature sg ->
+      let c =
+        { comp_values = Tbl.empty; comp_annotations = Tbl.empty;
+          comp_constrs = Tbl.empty;
+          comp_labels = Tbl.empty; comp_types = Tbl.empty;
+          comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
+          comp_components = Tbl.empty; comp_classes = Tbl.empty;
+          comp_cltypes = Tbl.empty } in
+      let (pl, sub) = prefix_idents path 0 sub sg in
+      let env = ref env in
+      let pos = ref 0 in
+      List.iter2 (fun item path ->
+        match item with
+          Tsig_value(id, decl) ->
+            let decl' = Subst.value_description sub decl in
+            c.comp_values <-
+              Tbl.add (Ident.name id) (decl', !pos) c.comp_values;
+            if !Clflags.annotations then begin
+              c.comp_annotations <-
+                Tbl.add (Ident.name id) (Annot.Iref_external, !pos)
+                        c.comp_annotations;
+            end;
+            begin match decl.val_kind with
+              Val_prim _ -> () | _ -> incr pos
+            end
+        | Tsig_type(id, decl, _) ->
+            let decl' = Subst.type_declaration sub decl in
+            c.comp_types <-
+              Tbl.add (Ident.name id) (decl', nopos) c.comp_types;
+            List.iter
+              (fun (name, descr) ->
+                c.comp_constrs <- Tbl.add name (descr, nopos) c.comp_constrs)
+              (constructors_of_type path decl');
+            List.iter
+              (fun (name, descr) ->
+                c.comp_labels <- Tbl.add name (descr, nopos) c.comp_labels)
+              (labels_of_type path decl');
+            env := store_type_infos id path decl !env
+        | Tsig_exception(id, decl) ->
+            let decl' = Subst.exception_declaration sub decl in
+            let cstr = Datarepr.exception_descr path decl' in
+            c.comp_constrs <-
+              Tbl.add (Ident.name id) (cstr, !pos) c.comp_constrs;
+            incr pos
+        | Tsig_module(id, mty, _) ->
+            let mty' = XLazy.create (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
+            c.comp_components <-
+              Tbl.add (Ident.name id) (comps, !pos) c.comp_components;
+            env := store_module id path mty !env;
+            incr pos
+        | Tsig_modtype(id, decl) ->
+            let decl' = Subst.modtype_declaration sub decl in
+            c.comp_modtypes <-
+              Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes;
+            env := store_modtype id path decl !env
+        | Tsig_class(id, decl, _) ->
+            let decl' = Subst.class_declaration sub decl in
+            c.comp_classes <-
+              Tbl.add (Ident.name id) (decl', !pos) c.comp_classes;
+            incr pos
+        | Tsig_cltype(id, decl, _) ->
+            let decl' = Subst.cltype_declaration sub decl in
+            c.comp_cltypes <-
+              Tbl.add (Ident.name id) (decl', !pos) c.comp_cltypes)
+        sg pl;
+        Structure_comps c
+  | Tmty_functor(param, ty_arg, ty_res) ->
+        Functor_comps {
+          fcomp_param = param;
+          (* fcomp_arg must be prefixed eagerly, because it is interpreted
+             in the outer environment, not in env *)
+          fcomp_arg = Subst.modtype sub ty_arg;
+          (* fcomp_res is prefixed lazily, because it is interpreted in env *)
+          fcomp_res = ty_res;
+          fcomp_env = env;
+          fcomp_subst = sub;
+          fcomp_cache = Hashtbl.create 17 }
+  | Tmty_ident p ->
+        Structure_comps {
+          comp_values = Tbl.empty; comp_annotations = Tbl.empty;
+          comp_constrs = Tbl.empty;
+          comp_labels = Tbl.empty; comp_types = Tbl.empty;
+          comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
+          comp_components = Tbl.empty; comp_classes = Tbl.empty;
+          comp_cltypes = Tbl.empty })
+
 (* Compute the components of a functor application in a path. *)
 
 let components_of_functor_appl f p1 p2 =
 (* Define forward functions *)
 
 let _ =
-  components_of_module' := components_of_module;
-  components_of_functor_appl' := components_of_functor_appl
+  components_of_module' := (fun (x,y,z,w) -> components_of_module x y z w);
+  components_of_functor_appl' := components_of_functor_appl;
+  force_components_of_module' := force_components_of_module;
+  force_subst_modtype' := XLazy.force (fun (sub, mty) -> Subst.modtype sub mty)
 
 (* Insertion of bindings by identifier *)