Fix performance regression introduced in 4.08 (#10624)

ocaml · Sep 10, 2021 · 75680ff · 75680ff
1 parent a2cef4d
commit 75680ff
Show file tree

Hide file tree

Showing 2 changed files with 20 additions and 11 deletions.
diff --git a/Changes b/Changes
@@ -153,6 +153,10 @@ Working version
 - #10559: Evaluate signature substitutions lazily
   (Stephen Dolan, review by Leo White)
 
+- #8776, #10624: Fix compilation time regression introduced in 4.08
+  (Nicolás Ojeda Bär, fix by Leo White, report by Alain Frisch, review by Thomas
+  Refis)
+
 ### Build system:
 
 ### Bug fixes:

diff --git a/typing/typeopt.ml b/typing/typeopt.ml
@@ -22,18 +22,23 @@ open Typedtree
 open Lambda
 
 let scrape_ty env ty =
-  let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in
   match get_desc ty with
-  | Tconstr (p, _, _) ->
-      begin match Env.find_type p env with
-      | {type_kind = ( Type_variant (_, Variant_unboxed)
-                     | Type_record (_, Record_unboxed _) ); _} -> begin
-          match Typedecl_unboxed.get_unboxed_type_representation env ty with
-          | None -> ty
-          | Some ty2 -> ty2
-        end
-      | _ -> ty
-      | exception Not_found -> ty
+  | Tconstr _ ->
+      let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in
+      begin match get_desc ty with
+      | Tconstr (p, _, _) ->
+          begin match Env.find_type p env with
+          | {type_kind = ( Type_variant (_, Variant_unboxed)
+          | Type_record (_, Record_unboxed _) ); _} -> begin
+              match Typedecl_unboxed.get_unboxed_type_representation env ty with
+              | None -> ty
+              | Some ty2 -> ty2
+          end
+          | _ -> ty
+          | exception Not_found -> ty
+          end
+      | _ ->
+          ty
       end
   | _ -> ty