Fix performance problem with PR#7016 and strengthen code

3 files changed, 32 insertions, 67 deletions

diff --git a/typing/ctype.ml b/typing/ctype.ml
index 3ba0a686d3..27fa0f288d 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -1575,58 +1575,12 @@ let generic_private_abbrev env path =
     | _ -> false
   with Not_found -> false
 
-let is_contractive env ty =
-  try match (repr ty).desc with
-    Tconstr (p, _, _) ->
-      let decl = Env.find_type p env in
-      in_pervasives p && decl.type_manifest = None || is_datatype decl
-  | _ -> true
+let is_contractive env p =
+  try
+    let decl = Env.find_type p env in
+    in_pervasives p && decl.type_manifest = None || is_datatype decl
   with Not_found -> false
 
-(* Code moved to Typedecl
-
-(* The marks are already used by [expand_abbrev]... *)
-let visited = ref []
-
-let rec non_recursive_abbrev env ty0 ty =
-  let ty = repr ty in
-  if ty == repr ty0 then raise Recursive_abbrev;
-  if not (List.memq ty !visited) then begin
-    visited := ty :: !visited;
-    match ty.desc with
-      Tconstr(p, args, abbrev) ->
-        begin try
-          non_recursive_abbrev env ty0 (try_expand_once_opt env ty)
-        with Cannot_expand ->
-          if !Clflags.recursive_types &&
-            (in_pervasives p ||
-             try is_datatype (Env.find_type p env) with Not_found -> false)
-          then ()
-          else iter_type_expr (non_recursive_abbrev env ty0) ty
-        end
-    | Tobject _ | Tvariant _ ->
-        ()
-    | _ ->
-        if !Clflags.recursive_types then () else
-        iter_type_expr (non_recursive_abbrev env ty0) ty
-  end
-
-let correct_abbrev env path params ty =
-  check_abbrev_env env;
-  let ty0 = newgenvar () in
-  visited := [];
-  let abbrev = Mcons (Public, path, ty0, ty0, Mnil) in
-  simple_abbrevs := abbrev;
-  try
-    non_recursive_abbrev env ty0
-      (subst env generic_level Public (ref abbrev) None [] [] ty);
-    simple_abbrevs := Mnil;
-    visited := []
-  with exn ->
-    simple_abbrevs := Mnil;
-    visited := [];
-    raise exn
-*)
 
                               (*****************)
                               (*  Occur check  *)
@@ -1635,39 +1589,46 @@ let correct_abbrev env path params ty =
 
 exception Occur
 
-let allow_recursive env ty =
-  (!Clflags.recursive_types || !umode = Pattern) && is_contractive env ty
-
-let rec occur_rec env visited ty0 ty =
+let rec occur_rec env allow_recursive visited ty0 = function
+  | {desc=Tlink ty} ->
+      occur_rec env allow_recursive visited ty0 ty
+  | ty ->
   if ty == ty0  then raise Occur;
-  if allow_recursive env ty then () else
   match ty.desc with
     Tconstr(p, tl, abbrev) ->
+      if allow_recursive && is_contractive env p then () else
       begin try
-        if List.memq ty visited then raise Occur;
-        iter_type_expr (occur_rec env (ty::visited) ty0) ty
+        if TypeSet.mem ty visited then raise Occur;
+        let visited = TypeSet.add ty visited in
+        iter_type_expr (occur_rec env allow_recursive visited ty0) ty
       with Occur -> try
         let ty' = try_expand_head try_expand_once env ty in
         (* This call used to be inlined, but there seems no reason for it.
            Message was referring to change in rev. 1.58 of the CVS repo. *)
-        occur_rec env visited ty0 ty'
+        occur_rec env allow_recursive visited ty0 ty'
       with Cannot_expand ->
         raise Occur
       end
   | Tobject _ | Tvariant _ ->
       ()
   | _ ->
-      if List.memq ty visited then () else
-      iter_type_expr (occur_rec env (ty::visited) ty0) ty
+      if allow_recursive ||  TypeSet.mem ty visited then () else begin
+        let visited = TypeSet.add ty visited in
+        iter_type_expr (occur_rec env allow_recursive visited ty0) ty
+      end
 
 let type_changed = ref false (* trace possible changes to the studied type *)
 
 let merge r b = if b then r := true
 
 let occur env ty0 ty =
+  let allow_recursive = !Clflags.recursive_types || !umode = Pattern  in
   let old = !type_changed in
   try
-    while type_changed := false; occur_rec env [] ty0 ty; !type_changed
+    while
+      type_changed := false;
+      occur_rec env allow_recursive TypeSet.empty ty0 ty;
+      !type_changed
     do () (* prerr_endline "changed" *) done;
     merge type_changed old
   with exn ->
@@ -1687,7 +1648,7 @@ let rec local_non_recursive_abbrev visited env p ty =
     match ty.desc with
       Tconstr(p', args, abbrev) ->
         if Path.same p p' then raise Occur;
-        if is_contractive env ty then () else
+        if is_contractive env p' then () else
         let visited = ty :: visited in
         begin try
           List.iter (local_non_recursive_abbrev visited env p) args
diff --git a/typing/ctype.mli b/typing/ctype.mli
index b4618d23f4..90bfcbe6de 100644
--- a/typing/ctype.mli
+++ b/typing/ctype.mli
@@ -248,7 +248,7 @@ val nondep_cltype_declaration:
         (* Same for class type declarations. *)
 (*val correct_abbrev: Env.t -> Path.t -> type_expr list -> type_expr -> unit*)
 val cyclic_abbrev: Env.t -> Ident.t -> type_expr -> bool
-val is_contractive: Env.t -> type_expr -> bool
+val is_contractive: Env.t -> Path.t -> bool
 val normalize_type: Env.t -> type_expr -> unit
 
 val closed_schema: Env.t -> type_expr -> bool
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index e0d8089f06..a2f4a2b3b3 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -518,11 +518,15 @@ let check_well_founded env loc path to_check ty =
       | _ -> raise Ctype.Cannot_expand
     with
     | Ctype.Cannot_expand ->
+        let rec_ok =
+          match ty.desc with
+            Tconstr(p,_,_) ->
+              !Clflags.recursive_types && Ctype.is_contractive env p
+          | Tobject _ | Tvariant _ -> true
+          | _ -> !Clflags.recursive_types
+        in
         let nodes =
-          if !Clflags.recursive_types && Ctype.is_contractive env ty
-          || match ty.desc with Tobject _ | Tvariant _ -> true | _ -> false
-          then TypeSet.empty
-          else exp_nodes in
+          if rec_ok then TypeSet.empty else exp_nodes in
         Btype.iter_type_expr (check ty0 nodes) ty
     | Ctype.Unify _ ->
         (* Will be detected by check_recursion *)