Merge pull request #193 from oxcaml/make-short-paths-lazier

Stop forcing substitutions while constructing short-paths graph

Author: dkalinichenko-js

src/ocaml/typing/env.ml

@@ -830,11 +830,11 @@ and cltype_data =
 and short_paths_addition =
   | Type of Ident.t * type_declaration
   | Class_type of Ident.t * class_type_declaration
-  | Module_type of Ident.t * modtype_declaration
-  | Module of Ident.t * module_declaration * module_components
+  | Module_type of Ident.t * Subst.Lazy.modtype_declaration
+  | Module of Ident.t * Subst.Lazy.module_declaration * module_components
   | Type_open of Path.t * type_data NameMap.t
   | Class_type_open of Path.t * class_type_declaration NameMap.t
-  | Module_type_open of Path.t * modtype_declaration NameMap.t
+  | Module_type_open of Path.t * Subst.Lazy.modtype_declaration NameMap.t
   | Module_open of Path.t * module_data NameMap.t
 
 let clda_mode = Mode.Value.(
@@ -2226,20 +2226,15 @@ let short_paths_class_type_open path decls old =
   else Class_type_open(path, decls) :: old
 
 let short_paths_module_type id decl old =
-  let decl = Subst.Lazy.force_modtype_decl decl in
   if !Clflags.real_paths then old
   else Module_type(id, decl) :: old
 
 let short_paths_module_type_open path decls old =
-  let decls = NameMap.map
-    (fun mtda -> Subst.Lazy.force_modtype_decl mtda.mtda_declaration)
-    decls
-  in
+  let decls = NameMap.map (fun mtda -> mtda.mtda_declaration) decls in
   if !Clflags.real_paths then old
   else Module_type_open(path, decls) :: old
 
 let short_paths_module id decl comps old =
-  let decl = Subst.Lazy.force_module_decl decl in
   if !Clflags.real_paths then old
   else Module(id, decl, comps) :: old
 
@@ -5354,7 +5349,7 @@ let short_paths_class_type_desc clty =
         | ns -> Subst(path, ns)
       end
 
-let short_paths_module_type_desc mty =
+let short_paths_module_type_desc (mty : Subst.Lazy.module_type option) =
   let open Short_paths.Desc.Module_type in
   match mty with
   | None | Some Mty_for_hole -> Fresh
@@ -5378,13 +5373,14 @@ let deprecated_of_alerts alerts =
 let deprecated_of_attributes attrs =
   deprecated_of_alerts (Builtin_attributes.alerts_of_attrs attrs)
 
-let scrape =
-  (* to be filled with Mtype.scrape_alias *)
-  ref ((fun _env _mty -> assert false) : t -> module_type -> module_type)
+let scrape_lazy =
+  (* to be filled with Mtype.scrape_lazy *)
+  ref ((fun (_env : t) (_mty : Subst.Lazy.module_type) : Subst.Lazy.module_type ->
+    assert false))
 
 let rec short_paths_module_desc env mpath mty comp =
   let open Short_paths.Desc.Module in
-  match !scrape env mty with
+  match !scrape_lazy env mty with
   | Mty_alias path -> Alias path
   | Mty_ident _ -> Fresh (Signature (lazy []))
   | Mty_signature _ ->
@@ -5423,19 +5419,17 @@ and short_paths_module_components_desc env mpath comp =
       in
       let comps =
         String.Map.fold (fun name mtda acc ->
-          let mtd = Subst.Lazy.force_modtype_decl mtda.mtda_declaration in
-          let desc = short_paths_module_type_desc mtd.mtd_type in
-          let depr = deprecated_of_attributes mtd.mtd_attributes in
+          let desc = short_paths_module_type_desc mtda.mtda_declaration.mtd_type in
+          let depr = deprecated_of_attributes mtda.mtda_declaration.mtd_attributes in
           let item = Short_paths.Desc.Module.Module_type(name, desc, depr) in
           item :: acc
         ) c.comp_modtypes comps
       in
       let comps =
         String.Map.fold (fun name { mda_declaration; mda_components; _ } acc ->
-          let mty = Subst.Lazy.force_module_decl mda_declaration in
           let mpath = Pdot(mpath, name) in
           let desc =
-            short_paths_module_desc env mpath mty.md_type mda_components
+            short_paths_module_desc env mpath mda_declaration.md_type mda_components
           in
           let depr = deprecated_of_alerts mda_components.alerts in
           let item = Short_paths.Desc.Module.Module(name, desc, depr) in
@@ -5465,6 +5459,7 @@ and short_paths_functor_components_desc env mpath comp path =
           stamped_path_add f.fcomp_subst_cache path mty;
           mty
       in
+      let mty = Subst.Lazy.of_modtype mty in
       let loc = Location.(in_file !input_name) in
       let comps =
         components_of_functor_appl ~loc ~f_comp:f env ~f_path:mpath ~arg:path
@@ -5492,9 +5487,7 @@ let short_paths_additions_desc env additions =
            let depr = deprecated_of_attributes mtd.mtd_attributes in
            Short_paths.Desc.Module_type(id, desc, source, depr) :: acc
        | Module(id, md, comps) ->
-           let desc =
-             short_paths_module_desc env (Pident id) md.md_type comps
-           in
+           let desc = short_paths_module_desc env (Pident id) md.md_type comps in
            let source = Short_paths.Desc.Local in
            let depr = deprecated_of_alerts comps.alerts in
            Short_paths.Desc.Module(id, desc, source, depr) :: acc
@@ -5520,7 +5513,7 @@ let short_paths_additions_desc env additions =
              decls acc
        | Module_type_open(root, decls) ->
            String.Map.fold
-             (fun name mtd acc ->
+             (fun name (mtd : Subst.Lazy.modtype_declaration) acc ->
                 let id = Ident.create_local name in
                 let path = Pdot(root, name) in
                 let desc = Short_paths.Desc.Module_type.Alias path in

src/ocaml/typing/env.mli

@@ -754,7 +754,7 @@ val with_cmis : (unit -> 'a) -> 'a
 
 val add_merlin_extension_module: Ident.t -> module_type -> t -> t
 val cleanup_functor_caches : stamp:int -> unit
-val scrape: (t -> module_type -> module_type) ref
+val scrape_lazy: (t -> Subst.Lazy.module_type -> Subst.Lazy.module_type) ref
 val cleanup_usage_tables : stamp:int -> unit
 
 (** This value should be filled in with [Msupport.raise_error]. [Env] cannot use this

src/ocaml/typing/mtype.ml

@@ -422,7 +422,7 @@ let scrape env mty =
 let () =
   Printtyp.expand_module_type := expand ;
   Env.scrape_alias := scrape_alias_lazy ;
-  Env.scrape := scrape
+  Env.scrape_lazy := scrape_lazy
 
 let find_type_of_module ~strengthen ~aliasable env path =
   if strengthen then

tests/test-dirs/function-recovery.t

@@ -10,7 +10,7 @@
     "value": "[
     structure_item (test.ml[1,0+0]..test.ml[3,104+28])
       Tstr_module
-      ERROR_locate_from_inside_function_literal_used_as_non_function/284
+      ERROR_locate_from_inside_function_literal_used_as_non_function/277
         module_expr (test.ml[1,0+72]..test.ml[3,104+28])
           Tmod_structure
           [
@@ -19,7 +19,7 @@
               [
                 <def>
                   pattern (test.ml[2,79+6]..test.ml[2,79+13])
-                    Tpat_var \"problem/282\"
+                    Tpat_var \"problem/275\"
                     sort value
                     value_mode meet(local,once,nonportable,unforkable,yielding,stateful)(modevar#4[global,many,portable,forkable,unyielding,stateless .. global,once,nonportable,unforkable,yielding,stateful]);imply(unique,uncontended,read_write)(modevar#5[aliased,contended,immutable .. unique,uncontended,read_write])
                   expression (test.ml[2,79+16]..test.ml[2,79+24])
@@ -49,7 +49,7 @@
                               expression (_none_[0,0+-1]..[0,0+-1]) ghost
                                 Pexp_constant PConst_int (1,None)
                           ]
-                        Texp_ident \"*type-error*/283\"
+                        Texp_ident \"*type-error*/276\"
               ]
           ]
   ]
@@ -69,7 +69,7 @@
       [
         <def>
           pattern (type.ml[1,0+4]..type.ml[1,0+5])
-            Tpat_var \"f/282\"
+            Tpat_var \"f/275\"
             sort value
             value_mode meet(local,once,nonportable,unforkable,yielding,stateful)(modevar#2[global,many,portable,forkable,unyielding,stateless .. global,once,nonportable,unforkable,yielding,stateful]);imply(unique,uncontended,read_write)(modevar#3[aliased,contended,immutable .. unique,uncontended,read_write])
           expression (type.ml[1,0+8]..type.ml[1,0+61])
@@ -87,10 +87,10 @@
                       Ttyp_constr \"list/11!\"
                       [
                         core_type (type.ml[1,0+28]..type.ml[1,0+29])
-                          Ttyp_constr \"t/284\"
+                          Ttyp_constr \"t/277\"
                           []
                       ]
-                  Tpat_var \"foo/285\"
+                  Tpat_var \"foo/278\"
                   sort value
                   value_mode map_comonadic(local_to_regional)(modevar#6[global,many,portable,forkable,unyielding,stateless .. local,once,nonportable,unforkable,yielding,stateful]);imply(unique,uncontended,read_write)(modevar#7[aliased,contended,immutable .. unique,uncontended,read_write])
             ]
@@ -103,7 +103,7 @@
                       extra
                         Tpat_extra_constraint
                         core_type (type.ml[1,0+48]..type.ml[1,0+49])
-                          Ttyp_constr \"t/284\"
+                          Ttyp_constr \"t/277\"
                           []
                       Tpat_any
                     expression (type.ml[1,0+53]..type.ml[1,0+55])
@@ -116,7 +116,7 @@
                             expression (_none_[0,0+-1]..[0,0+-1]) ghost
                               Pexp_constant PConst_int (1,None)
                         ]
-                      Texp_ident \"*type-error*/286\"
+                      Texp_ident \"*type-error*/279\"
                 ]
                 expression (type.ml[1,0+59]..type.ml[1,0+61])
                   attribute \"merlin.loc\"
@@ -195,7 +195,7 @@
                     "ghost": false,
                     "attrs": [],
                     "kind": "pattern (test.ml[1,0+4]..test.ml[1,0+5])
-    Tpat_var \"f/282\"
+    Tpat_var \"f/275\"
     sort value
     value_mode meet(local,once,nonportable,unforkable,yielding,stateful)(modevar#2[global,many,portable,forkable,unyielding,stateless .. global,once,nonportable,unforkable,yielding,stateful]);imply(unique,uncontended,read_write)(modevar#3[aliased,contended,immutable .. unique,uncontended,read_write])
   ",
@@ -228,7 +228,7 @@
                         "ghost": false,
                         "attrs": [],
                         "kind": "pattern (test.ml[1,0+6]..test.ml[1,0+9])
-    Tpat_var \"x/284\"
+    Tpat_var \"x/277\"
     sort '_representable_layout_1
     value_mode map_comonadic(local_to_regional)(modevar#6[global,many,portable,forkable,unyielding,stateless .. local,once,nonportable,unforkable,yielding,stateful]);imply(unique,uncontended,read_write)(modevar#7[aliased,contended,immutable .. unique,uncontended,read_write])
   ",
@@ -460,7 +460,7 @@
     Tpat_construct \"Some\"
     [
       pattern (test.ml[4,57+9]..test.ml[4,57+12])
-        Tpat_var \"_aa/285\"
+        Tpat_var \"_aa/278\"
         sort value
         value_mode global,many,portable,forkable,unyielding,stateless;unique,uncontended,read_write
     ]
@@ -480,7 +480,7 @@
                                         "ghost": false,
                                         "attrs": [],
                                         "kind": "pattern (test.ml[4,57+9]..test.ml[4,57+12])
-    Tpat_var \"_aa/285\"
+    Tpat_var \"_aa/278\"
     sort value
     value_mode global,many,portable,forkable,unyielding,stateless;unique,uncontended,read_write
   ",

tests/test-dirs/server-tests/typer-cache/stamps.t/run.t

@@ -8,31 +8,31 @@ buffers, and different runs for the same buffer:
   $ echo "let f x = x" | \
   > $MERLIN server dump -what browse -filename test.ml | \
   > sed 's:\\n:\n:g' | grep Tpat_var
-    Tpat_var \"f/282\"
-    Tpat_var \"x/284\"
+    Tpat_var \"f/275\"
+    Tpat_var \"x/277\"
 
   $ echo "let f x = let () = () in x" | \
   > $MERLIN server dump -what browse -filename test.ml | \
   > sed 's:\\n:\n:g' | grep Tpat_var
-    Tpat_var \"f/285\"
-    Tpat_var \"x/287\"
+    Tpat_var \"f/278\"
+    Tpat_var \"x/280\"
 
   $ echo "let f x = x" | \
   > $MERLIN server dump -what browse -filename other_test.ml | \
   > sed 's:\\n:\n:g' | grep Tpat_var
-    Tpat_var \"f/282\"
-    Tpat_var \"x/284\"
+    Tpat_var \"f/275\"
+    Tpat_var \"x/277\"
 
   $ echo "let f x = let () = () in x" | \
   > $MERLIN server dump -what browse -filename test.ml | \
   > sed 's:\\n:\n:g' | grep Tpat_var
-    Tpat_var \"f/285\"
-    Tpat_var \"x/287\"
+    Tpat_var \"f/278\"
+    Tpat_var \"x/280\"
 
   $ echo "let f x = x" | \
   > $MERLIN server dump -what browse -filename test.ml | \
   > sed 's:\\n:\n:g' | grep Tpat_var
-    Tpat_var \"f/288\"
-    Tpat_var \"x/290\"
+    Tpat_var \"f/281\"
+    Tpat_var \"x/283\"
 
   $ $MERLIN server stop-server

tests/test-dirs/type-enclosing/underscore-ids.t

@@ -443,7 +443,7 @@ We try several places in the identifier to check the result stability
       [
         <def>
           pattern (under.ml[1,0+4]..under.ml[1,0+6])
-            Tpat_var \"aa/282\"
+            Tpat_var \"aa/275\"
             sort value
             value_mode meet(local,once,nonportable,unforkable,yielding,stateful)(modevar#2[global,many,portable,forkable,unyielding,stateless .. global,once,nonportable,unforkable,yielding,stateful]);imply(unique,uncontended,read_write)(modevar#3[aliased,contended,immutable .. unique,uncontended,read_write])
           expression (under.ml[1,0+9]..under.ml[1,0+12])
@@ -454,7 +454,7 @@ We try several places in the identifier to check the result stability
       [
         <def>
           pattern (under.ml[2,13+4]..under.ml[2,13+5])
-            Tpat_var \"f/283\"
+            Tpat_var \"f/276\"
             sort value
             value_mode meet(local,once,nonportable,unforkable,yielding,stateful)(modevar#9[global,many,portable,forkable,unyielding,stateless .. global,once,nonportable,unforkable,yielding,stateful]);imply(unique,uncontended,read_write)(modevar#a[aliased,contended,immutable .. unique,uncontended,read_write])
           expression (under.ml[2,13+6]..under.ml[5,70+17]) ghost
@@ -464,7 +464,7 @@ We try several places in the identifier to check the result stability
               Nolabel
               Param_pat
                 pattern (under.ml[2,13+6]..under.ml[2,13+9])
-                  Tpat_var \"x/285\"
+                  Tpat_var \"x/278\"
                   sort '_representable_layout_1
                   value_mode map_comonadic(local_to_regional)(modevar#d[global,many,portable,forkable,unyielding,stateless .. local,once,nonportable,unforkable,yielding,stateful]);imply(unique,uncontended,read_write)(modevar#e[aliased,contended,immutable .. unique,uncontended,read_write])
             ]
@@ -479,7 +479,7 @@ We try several places in the identifier to check the result stability
                       expression (_none_[0,0+-1]..[0,0+-1]) ghost
                         Pexp_constant PConst_int (1,None)
                   ]
-                Texp_ident \"*type-error*/288\"
+                Texp_ident \"*type-error*/281\"
       ]
   ]