Merge pull request ocaml#13507 from goldfirere/exists-free-variable

Add closed_type_expr

Changes

@@ -544,6 +544,10 @@ ___________
   in Float.Array.
   (Gabriel Scherer, review by Nicolás Ojeda Bär)
 
+- #13507: A small refactoring to [free_vars] to make it a bit faster
+  by not allocating a list when the list is not necessary.
+  (Richard Eisenberg, review by Jacques Garrigue)
+
 ### Build system:
 
 - #12909: Reorganise how MKEXE_VIA_CC is built to make it correct for MSVC by

typing/ctype.ml

@@ -592,35 +592,34 @@ let rec filter_row_fields erase = function
 type variable_kind = Row_variable | Type_variable
 exception Non_closed of type_expr * variable_kind
 
-(* [free_vars] collects the variables of the input type expression. It
+(* [free_vars] walks over the variables of the input type expression. It
    is used for several different things in the type-checker, with the
    following bells and whistles:
    - If [env] is Some typing environment, types in the environment
      are expanded to check whether the apparently-free variable would vanish
      during expansion.
-   - We collect both type variables and row variables, paired with
-     a [variable_kind] to distinguish them.
    - We do not count "virtual" free variables -- free variables stored in
      the abbreviation of an object type that has been expanded (we store
      the abbreviations for use when displaying the type).
 
-   [free_vars] returns a [(variable * bool) list], while
-   [free_variables] below drops the type/row information
-   and only returns a [variable list].
+   [free_vars] accumulates its answer in a monoid-like structure, with
+   an initial element [zero] and a combining function [add_one], passing
+   [add_one] information about whether the variable is a normal type variable
+   or a row variable.
  *)
-let free_vars ?env mark ty =
+let free_vars ~init ~add_one ?env mark ty =
   let rec fv ~kind acc ty =
     if not (try_mark_node mark ty) then acc
     else match get_desc ty, env with
       | Tvar _, _ ->
-          (ty, kind) :: acc
+          add_one ty kind acc
       | Tconstr (path, tl, _), Some env ->
           let acc =
             match Env.find_type_expansion path env with
             | exception Not_found -> acc
             | (_, body, _) ->
                 if get_level body = generic_level then acc
-                else (ty, kind) :: acc
+                else add_one ty kind acc
           in
           List.fold_left (fv ~kind:Type_variable) acc tl
       | Tobject (ty, _), _ ->
@@ -636,15 +635,20 @@ let free_vars ?env mark ty =
           else fv ~kind:Row_variable acc (row_more row)
       | _    ->
           fold_type_expr (fv ~kind) acc ty
-  in fv ~kind:Type_variable [] ty
+  in fv ~kind:Type_variable init ty
 
 let free_variables ?env ty =
-  with_type_mark (fun mark -> List.map fst (free_vars ?env mark ty))
+  let add_one ty _kind acc = ty :: acc in
+  with_type_mark (fun mark -> free_vars ~init:[] ~add_one ?env mark ty)
 
-let closed_type mark ty =
-  match free_vars mark ty with
-      []           -> ()
-  | (v, real) :: _ -> raise (Non_closed (v, real))
+let closed_type ?env mark ty =
+  let add_one ty kind _acc = raise (Non_closed (ty, kind)) in
+  free_vars ~init:() ~add_one ?env mark ty
+
+let closed_type_expr ?env ty =
+  with_type_mark (fun mark ->
+    try closed_type ?env mark ty; true
+    with Non_closed _ -> false)
 
 let closed_parameterized_type params ty =
   with_type_mark begin fun mark ->

typing/ctype.mli

@@ -451,6 +451,7 @@ type closed_class_failure = {
 
 val free_variables: ?env:Env.t -> type_expr -> type_expr list
         (* If env present, then check for incomplete definitions too *)
+val closed_type_expr: ?env:Env.t -> type_expr -> bool
 val closed_type_decl: type_declaration -> type_expr option
 val closed_extension_constructor: extension_constructor -> type_expr option
 val closed_class:

typing/typecore.ml

@@ -717,7 +717,7 @@ and build_as_type_extra env p = function
   | (Tpat_constraint {ctyp_type = ty; _}, _, _) :: rest ->
       (* If the type constraint is ground, then this is the best type
          we can return, so just return an instance (cf. #12313) *)
-      if free_variables ty = [] then instance ty else
+      if closed_type_expr ty then instance ty else
       (* Otherwise we combine the inferred type for the pattern with
          then non-ground constraint in a non-ambivalent way *)
       let as_ty = build_as_type_extra env p rest in
@@ -4463,8 +4463,8 @@ and type_coerce
           (* prerr_endline "self coercion"; *)
           r := loc :: !r;
           force ()
-      | _ when free_variables ~env arg_type = []
-            && free_variables ~env ty' = [] ->
+      | _ when closed_type_expr ~env arg_type
+            && closed_type_expr ~env ty' ->
           if not gen && (* first try a single coercion *)
             let snap = snapshot () in
             let ty, _b = enlarge_type env ty' in

typing/typemod.ml

@@ -2103,7 +2103,7 @@ let modtype_of_package env loc p fl =
 let package_subtype env p1 fl1 p2 fl2 =
   let mkmty p fl =
     let fl =
-      List.filter (fun (_n,t) -> Ctype.free_variables t = []) fl in
+      List.filter (fun (_n,t) -> Ctype.closed_type_expr t) fl in
     modtype_of_package env Location.none p fl
   in
   match mkmty p1 fl1, mkmty p2 fl2 with
@@ -2300,7 +2300,8 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
       let mty =
         match get_desc (Ctype.expand_head env exp.exp_type) with
           Tpackage (p, fl) ->
-            if List.exists (fun (_n, t) -> Ctype.free_variables t <> []) fl then
+            if List.exists (fun (_n, t) -> not (Ctype.closed_type_expr t)) fl
+            then
               raise (Error (smod.pmod_loc, env,
                             Incomplete_packed_module exp.exp_type));
             if !Clflags.principal &&