From fc5061c198ff340fd3e4553882db851acf9c7376 Mon Sep 17 00:00:00 2001
From: Gabriel Scherer <gabriel.scherer@gmail.com>
Date: Sat, 26 Dec 2020 15:37:05 +0100
Subject: [PATCH] Merge pull request #10096 from gasche/fix-oo-caching-problem

fix a caching problem in OO code causing a 4.11 performance regression

(cherry picked from commit 9f53c6b71af2ad75de0dd9799037a0259bd4b12d)
---
 Changes              | 15 ++++++++++++---
 lambda/translcore.ml | 32 ++++++++++++++++++--------------
 2 files changed, 30 insertions(+), 17 deletions(-)

diff --git a/Changes b/Changes
index cad1b33f62fe..ee85c8255389 100644
--- a/Changes
+++ b/Changes
@@ -680,8 +680,17 @@ OCaml 4.12.0
 - #10048: Fix bug with generalized local opens.
   (Leo White, review by Thomas Refis)
 
-OCaml 4.11.1
-------------
+OCaml 4.11 maintenance branch
+-----------------------------
+
+### Bug fixes:
+
+- #9096, #10096: fix a 4.11.0 performance regression in classes/objects
+  declared within a function
+  (Gabriel Scherer, review by Leo White, report by Sacha Ayoun)
+
+OCaml 4.11.1 (31 August 2020)
+-----------------------------
 
 ### Bug fixes:
 
@@ -694,7 +703,7 @@ OCaml 4.11.1
   (Florian Angeletti, review by Thomas Refis)
 
 OCaml 4.11.0 (19 August 2020)
----------------------------
+-----------------------------
 
 (Changes that can break existing programs are marked with a "*")
 
diff --git a/lambda/translcore.ml b/lambda/translcore.ml
index c195b7656b00..653f12ce8bc2 100644
--- a/lambda/translcore.ml
+++ b/lambda/translcore.ml
@@ -219,6 +219,14 @@ let transl_ident loc env ty path desc =
   |  _ -> fatal_error "Translcore.transl_exp: bad Texp_ident"
 
 let rec transl_exp ~scopes e =
+  transl_exp1 ~scopes ~in_new_scope:false e
+
+(* ~in_new_scope tracks whether we just opened a new scope.
+
+   We go to some trouble to avoid introducing many new anonymous function
+   scopes, as `let f a b = ...` is desugared to several Pexp_fun.
+*)
+and transl_exp1 ~scopes ~in_new_scope e =
   List.iter (Translattribute.check_attribute e) e.exp_attributes;
   let eval_once =
     (* Whether classes for immediate objects must be cached *)
@@ -226,10 +234,10 @@ let rec transl_exp ~scopes e =
       Texp_function _ | Texp_for _ | Texp_while _ -> false
     | _ -> true
   in
-  if eval_once then transl_exp0 ~scopes e else
-  Translobj.oo_wrap e.exp_env true (transl_exp0 ~scopes) e
+  if eval_once then transl_exp0 ~scopes ~in_new_scope  e else
+  Translobj.oo_wrap e.exp_env true (transl_exp0 ~scopes ~in_new_scope) e
 
-and transl_exp0 ~scopes e =
+and transl_exp0 ~in_new_scope ~scopes e =
   match e.exp_desc with
   | Texp_ident(path, _, desc) ->
       transl_ident (of_location ~scopes e.exp_loc)
@@ -240,7 +248,10 @@ and transl_exp0 ~scopes e =
       transl_let ~scopes rec_flag pat_expr_list
         (event_before ~scopes body (transl_exp ~scopes body))
   | Texp_function { arg_label = _; param; cases; partial; } ->
-      let scopes = enter_anonymous_function ~scopes in
+      let scopes =
+        if in_new_scope then scopes
+        else enter_anonymous_function ~scopes
+      in
       transl_function ~scopes e param cases partial
   | Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p});
                 exp_type = prim_type } as funct, oargs)
@@ -850,18 +861,11 @@ and transl_function ~scopes e param cases partial =
   let lam = Lfunction{kind; params; return; body; attr; loc} in
   Translattribute.add_function_attributes lam e.exp_loc e.exp_attributes
 
-(* Like transl_exp, but used when introducing a new scope.
-   Goes to some trouble to avoid introducing many new anonymous function
-   scopes, as `let f a b = ...` is desugared to several Pexp_fun *)
+(* Like transl_exp, but used when a new scope was just introduced. *)
 and transl_scoped_exp ~scopes expr =
-  match expr.exp_desc with
-  | Texp_function { arg_label = _; param; cases; partial } ->
-     transl_function ~scopes expr param cases partial
-  | _ ->
-     transl_exp ~scopes expr
+  transl_exp1 ~scopes ~in_new_scope:true expr
 
-(* Calls transl_scoped_exp or transl_exp, according to whether a pattern
-   binding should introduce a new scope *)
+(* Decides whether a pattern binding should introduce a new scope. *)
 and transl_bound_exp ~scopes ~in_structure pat expr =
   let should_introduce_scope =
     match expr.exp_desc with