Merge pull request #201 from oxcaml/merge-5.2.0minus-24

Merge 5.2.0minus-24

Author: liam923

src/analysis/completion.ml

@@ -37,8 +37,8 @@ let { Logger.log } = Logger.for_section "Completion"
 
 type raw_info =
   [ `Constructor of Types.constructor_description
-  | `Modtype of Types.module_type
-  | `Modtype_declaration of Ident.t * Types.modtype_declaration
+  | `Modtype of Subst.Lazy.module_type
+  | `Modtype_declaration of Ident.t * Subst.Lazy.modtype_declaration
   | `None
   | `String of string
   | `Type_declaration of Ident.t * Types.type_declaration
@@ -47,8 +47,11 @@ type raw_info =
 
 let raw_info_printer : raw_info -> _ = function
   | `Constructor c -> `Print (Out_type (Browse_misc.print_constructor c))
-  | `Modtype mt -> `Print (Out_module_type (Printtyp.tree_of_modtype mt))
+  | `Modtype mt ->
+    let mt = Subst.Lazy.force_modtype mt in
+    `Print (Out_module_type (Printtyp.tree_of_modtype mt))
   | `Modtype_declaration (id, mtd) ->
+    let mtd = Subst.Lazy.force_modtype_decl mtd in
     `Print (Out_sig_item (Printtyp.tree_of_modtype_declaration id mtd))
   | `None -> `String ""
   | `String s -> `String s
@@ -315,8 +318,8 @@ let get_candidates ?get_doc ?target_type ?prefix_path ~prefix kind ~validate env
   let val_attributes v = v.Subst.Lazy.val_attributes in
   let type_attributes t = t.Types.type_attributes in
   let lbl_attributes l = l.Types.lbl_attributes in
-  let mtd_attributes t = t.Types.mtd_attributes in
-  let md_attributes t = t.Types.md_attributes in
+  let mtd_attributes t = t.Subst.Lazy.mtd_attributes in
+  let md_attributes t = t.Subst.Lazy.md_attributes in
   let make_candidate ~attrs ~exact name ?loc ?path ty =
     make_candidate ~get_doc ~prefix_path ~attrs ~exact name ?loc ?path ty
   in
@@ -459,18 +462,18 @@ let get_candidates ?get_doc ?target_type ?prefix_path ~prefix kind ~validate env
               :: candidates)
           prefix_path env []
       | `Modules ->
-        Env.fold_modules
+        Env.fold_modules_lazy
           (fun name path v candidates ->
             let attrs = md_attributes v in
-            let v = v.Types.md_type in
+            let v = v.Subst.Lazy.md_type in
             if not @@ validate `Uident `Mod name then candidates
             else
               make_weighted_candidate ~exact:(name = prefix) name ~path (`Mod v)
                 ~attrs
               :: candidates)
           prefix_path env []
       | `Modules_type ->
-        Env.fold_modtypes
+        Env.fold_modtypes_lazy
           (fun name path v candidates ->
             if not @@ validate `Uident `Mod name then candidates
             else
@@ -683,8 +686,8 @@ let complete_prefix ?get_doc ?target_type ?(kinds = []) ~keywords ~prefix
   with Not_found -> []
 
 (* Propose completion from a particular node *)
-let branch_complete buffer ?get_doc ?target_type ?kinds ~keywords prefix =
-  function
+let branch_complete buffer ?get_doc ?target_type ?kinds ~keywords prefix :
+    _ -> raw_info raw_entry list = function
   | [] -> []
   | (env, node) :: branch -> (
     match node with

src/analysis/completion.mli

@@ -32,8 +32,8 @@ open Query_protocol
 
 type raw_info =
   [ `Constructor of Types.constructor_description
-  | `Modtype of Types.module_type
-  | `Modtype_declaration of Ident.t * Types.modtype_declaration
+  | `Modtype of Subst.Lazy.module_type
+  | `Modtype_declaration of Ident.t * Subst.Lazy.modtype_declaration
   | `None
   | `String of string
   | `Type_declaration of Ident.t * Types.type_declaration

src/analysis/env_lookup.ml

@@ -113,12 +113,12 @@ let by_longident (nss : Namespace.inferred list) ident env =
             raise (Found (path, Constructor, cd.cstr_uid, loc))
           | `Mod ->
             log ~title:"lookup" "lookup in module namespace";
-            let path, md = Env.find_module_by_name ident env in
-            raise (Found (path, Module, md.md_uid, md.Types.md_loc))
+            let path, md = Env.find_module_by_name_lazy ident env in
+            raise (Found (path, Module, md.md_uid, md.md_loc))
           | `Modtype ->
             log ~title:"lookup" "lookup in module type namespace";
-            let path, mtd = Env.find_modtype_by_name ident env in
-            raise (Found (path, Module_type, mtd.mtd_uid, mtd.Types.mtd_loc))
+            let path, mtd = Env.find_modtype_by_name_lazy ident env in
+            raise (Found (path, Module_type, mtd.mtd_uid, mtd.mtd_loc))
           | `Type ->
             log ~title:"lookup" "lookup in type namespace";
             let path, typ_decl = Env.find_type_by_name ident env in

src/analysis/locate.ml

@@ -348,7 +348,8 @@ module Preferences : sig
   val src : string -> File.t
   val build : string -> File.t
 
-  val is_preferred : string -> bool
+  val is_preferred_source : string -> bool
+  val is_preferred_build_or_source : string -> bool
 end = struct
   let prioritize_impl = ref true
 
@@ -361,11 +362,17 @@ end = struct
   let src file = if !prioritize_impl then File.ml file else File.mli file
   let build file = if !prioritize_impl then File.cms file else File.cmsi file
 
-  let is_preferred fn =
+  let is_preferred_source fn =
     match File.of_filename fn with
     | Some (ML _) -> !prioritize_impl
     | Some (MLI _) -> not !prioritize_impl
     | _ -> false
+
+  let is_preferred_build_or_source fn =
+    match File.of_filename fn with
+    | Some (ML _ | CMS _ | CMT _) -> !prioritize_impl
+    | Some (MLI _ | CMSI _ | CMTI _) -> not !prioritize_impl
+    | Some (MLL _) | None -> false
 end
 
 module File_switching : sig
@@ -469,10 +476,30 @@ module Utils = struct
           try Some (Misc.find_in_path_normalized ?fallback path fname)
           with Not_found -> None
         in
-        match try_one file with
-        | Some _ as f -> f
-        | None -> Option.bind ~f:try_one (File.to_legacy file)
+        (* Prefer files first by whether they're preferred and then by their legacy-ness.
+           (legacy = cmt/cmti, nonlegacy = cms/cmsi). Be as lazy as possible about finding
+           files, since this may involve looking through a lot of directories. *)
+        let rec find_first_preferred ~first_found_file files_to_try =
+          match files_to_try with
+          | file_to_try :: rest_files_to_try -> (
+            match try_one file_to_try with
+            | Some found_file as found_file_opt ->
+              if Preferences.is_preferred_build_or_source found_file then
+                found_file_opt
+              else
+                let first_found_file =
+                  match first_found_file with
+                  | Some _ as first_found_file -> first_found_file
+                  | None -> found_file_opt
+                in
+                find_first_preferred ~first_found_file rest_files_to_try
+            | None -> find_first_preferred ~first_found_file rest_files_to_try)
+          | [] -> first_found_file
+        in
+        find_first_preferred ~first_found_file:None
+          ([ Some file; File.to_legacy file ] |> List.filter_map ~f:(fun x -> x))
       in
+
       try
         Some (List.find_map Mconfig.(config.merlin.suffixes) ~f:attempt_search)
       with Not_found -> None
@@ -653,7 +680,7 @@ let find_source ~config loc =
             let path' = String.reverse path in
             let priority =
               (String.common_prefix_len rev path' * 2)
-              + if Preferences.is_preferred path then 1 else 0
+              + if Preferences.is_preferred_source path then 1 else 0
             in
             (priority, path))
       in

src/analysis/polarity_search.ml

@@ -115,7 +115,7 @@ let directories ~global_modules env =
   List.fold_left
     ~f:(fun l name ->
       let lident = Longident.Lident name in
-      match Env.find_module_by_name lident env with
+      match Env.find_module_by_name_lazy lident env with
       | exception _ -> l
       | _ -> Trie (name, lident, lazy (explore lident env)) :: l)
     ~init:[] global_modules
@@ -138,7 +138,7 @@ let execute_query query env dirs =
   in
   let rec recurse acc (Trie (_, dir, children)) =
     match
-      ignore (Env.find_module_by_name dir env);
+      ignore (Env.find_module_by_name_lazy dir env);
       Lazy.force children
     with
     | children ->

src/analysis/syntax_doc.ml

@@ -225,8 +225,12 @@ let get_mode_doc mode =
       Some "The mutable parts of values with this mode can be fully accessed"
     | Comonadic Portability, Nonportable ->
       Some
-        "Values with this mode cannot be sent to other threads, in order to \
-         avoid data races."
+        "Values with this mode cannot be sent to or shared with other threads, \
+         in order to avoid data races."
+    | Comonadic Portability, Shareable ->
+      Some
+        "Values with this mode can be shared with (but not sent to) other \
+         threads without causing data races"
     | Comonadic Portability, Portable ->
       Some
         "Values with this mode can be sent to other threads without causing \
@@ -263,6 +267,9 @@ let get_mode_doc mode =
       Some "Functions with this mode may be executed concurrently."
     | Comonadic Forkable, Unforkable ->
       Some "Functions with this mode cannot be executed concurrently."
+    | Monadic Staticity, Static -> Some "The value is known at compile-time."
+    | Monadic Staticity, Dynamic ->
+      Some "The value is not known at compile-time."
   in
   let doc_url =
     let subpage =
@@ -276,6 +283,7 @@ let get_mode_doc mode =
       | Monadic Visibility -> "modes/intro/"
       | Comonadic Statefulness -> "modes/intro/"
       | Comonadic Forkable -> "modes/intro/"
+      | Monadic Staticity -> "modes/intro/"
     in
     syntax_doc_url Oxcaml subpage
   in

src/analysis/type_search.ml

@@ -116,7 +116,7 @@ let compute_values query env lident acc =
 
 let values_from_module query env lident acc =
   let rec aux acc lident =
-    match Env.find_module_by_name lident env with
+    match Env.find_module_by_name_lazy lident env with
     | exception _ -> acc
     | _ ->
       let acc = compute_values query env (Some lident) acc in

src/analysis/type_utils.ml

@@ -59,8 +59,8 @@ let parse_longident lid =
   with Parser_raw.Error -> None
 
 let lookup_module name env =
-  let path, md = Env.find_module_by_name name env in
-  (path, md.Types.md_type, md.Types.md_attributes)
+  let path, md = Env.find_module_by_name_lazy name env in
+  (path, md.md_type, md.md_attributes)
 
 let verbosity = ref Verbosity.default
 
@@ -155,22 +155,22 @@ module Printtyp = struct
     let_ref verbosity v (fun () -> wrap_printing_env env f)
 end
 
-let si_modtype_opt = function
-  | Types.Sig_modtype (_, m, _) -> m.mtd_type
-  | Types.Sig_module (_, _, m, _, _) -> Some m.md_type
+let si_modtype_opt : Subst.Lazy.signature_item -> _ = function
+  | Sig_modtype (_, m, _) -> m.mtd_type
+  | Sig_module (_, _, m, _, _) -> Some m.md_type
   | _ -> None
 
 (* Check if module is smaller (= has less definition, counting nested ones)
  * than a particular threshold. Return (Some n) if module has size n, or None
  * otherwise (module is bigger than threshold).
  * Used to skip printing big modules in completion. *)
-let rec mod_smallerthan n m =
+let rec mod_smallerthan n (m : Subst.Lazy.module_type) =
   if n < 0 then None
   else
-    let open Types in
     match m with
     | Mty_ident _ -> Some 1
     | Mty_signature s -> begin
+      let s = Subst.Lazy.force_signature_once s in
       match List.length_lessthan n s with
       | None -> None
       | Some _ ->
@@ -190,17 +190,15 @@ let rec mod_smallerthan n m =
                 | Some n', _ -> Some (succ n')
             end
     end
-    | Mty_functor _ ->
-      let m1, m2 = unpack_functor m in
-      begin
-        match (mod_smallerthan n m2, m1) with
-        | None, _ -> None
-        | result, Unit -> result
-        | Some n1, Named (_, mt) -> (
-          match mod_smallerthan (n - n1) mt with
-          | None -> None
-          | Some n2 -> Some (n1 + n2))
-      end
+    | Mty_functor (m1, m2) -> begin
+      match (mod_smallerthan n m2, m1) with
+      | None, _ -> None
+      | result, Unit -> result
+      | Some n1, Named (_, mt) -> (
+        match mod_smallerthan (n - n1) mt with
+        | None -> None
+        | Some n2 -> Some (n1 + n2))
+    end
     | _ -> Some 1
 
 let print_short_modtype verbosity env ppf md =
@@ -209,7 +207,9 @@ let print_short_modtype verbosity env ppf md =
   match mod_smallerthan 1000 md with
   | None when verbosity = 0 ->
     Format.pp_print_string ppf "(* large signature, repeat to confirm *)"
-  | _ -> Printtyp.modtype env ppf md
+  | _ ->
+    let md = Subst.Lazy.force_modtype md in
+    Printtyp.modtype env ppf md
 
 let print_type_with_decl ~verbosity env ppf typ =
   match verbosity with
@@ -260,13 +260,13 @@ let print_type ppf verbosity env lid =
     end
 
 let print_modtype ppf verbosity env lid =
-  let _p, mtd = Env.find_modtype_by_name lid.Asttypes.txt env in
+  let _p, mtd = Env.find_modtype_by_name_lazy lid.Asttypes.txt env in
   match mtd.mtd_type with
   | Some mt -> print_short_modtype verbosity env ppf mt
   | None -> Format.pp_print_string ppf "(* abstract module *)"
 
 let print_modpath ppf verbosity env lid =
-  let _path, md = Env.find_module_by_name lid.Asttypes.txt env in
+  let _path, md = Env.find_module_by_name_lazy lid.Asttypes.txt env in
   print_short_modtype verbosity env ppf md.md_type
 
 let print_cstr_desc ppf cstr_desc =

src/analysis/type_utils.mli

@@ -50,7 +50,7 @@ end
     than a particular threshold. Return (Some n) if module has size n, or None
     otherwise (module is bigger than threshold).
     Used to skip printing big modules in completion. *)
-val mod_smallerthan : int -> Types.module_type -> int option
+val mod_smallerthan : int -> Subst.Lazy.module_type -> int option
 
 (** [type_in_env env ppf input] parses [input] and prints its type on [ppf].
     Returning true if it printed a type, false otherwise. *)
@@ -76,7 +76,7 @@ val print_type_with_decl :
 (** [lookup_module] is a fancier version of [Env.lookup_module] that also
     returns the module type. *)
 val lookup_module :
-  Longident.t -> Env.t -> Path.t * Types.module_type * Parsetree.attributes
+  Longident.t -> Env.t -> Path.t * Subst.Lazy.module_type * Parsetree.attributes
 
 (** [read_doc_attributes] looks for a docstring in an attribute list. *)
 val read_doc_attributes : Parsetree.attributes -> (string * Location.t) option

src/kernel/mconfig.ml

@@ -447,6 +447,7 @@ let ocaml_ignored_flags =
     "-dlinear";
     "-dparsetree";
     "-dshape";
+    "-dslambda";
     "-drawclambda";
     "-drawflambda";
     "-drawlambda";
@@ -622,6 +623,10 @@ let ocaml_ignored_flags =
     "-fno-avx2";
     "-favx";
     "-fno-avx";
+    "-ffma";
+    "-fno-fma";
+    "-ff16c";
+    "-fno-f16c";
     "-dllvmir";
     "-keep-llvmir";
     "-llvm-backend";
@@ -632,9 +637,17 @@ let ocaml_ignored_flags =
     "-no-cfg-prologue-validate";
     "-cfg-prologue-shrink-wrap";
     "-no-cfg-prologue-shrink-wrap";
+    "-cfg-value-propagation";
+    "-no-cfg-value-propagation";
+    "-cfg-value-propagation-float";
+    "-no-cfg-value-propagation-float";
     "-gdwarf-pedantic";
     "-ddwarf-metrics";
-    "-afl-instrument"
+    "-afl-instrument";
+    "-probes";
+    "-no-probes";
+    "-probes-optimized";
+    "-no-probes-optimized"
   ]
 
 let ocaml_ignored_parametrized_flags =
@@ -671,8 +684,8 @@ let ocaml_ignored_parametrized_flags =
     "-use-runtime";
     "-error-style";
     "-dump-dir";
-    "-I-paths";
-    "-H-paths";
+    "-I-manifest";
+    "-H-manifest";
     (* flambda-backend specific *)
     "-extension";
     "-extension-universe";