flambda-backend: Stop local function optimisation from moving code into function bodies; opaque_identity fixes for class compilation (oxcaml#537)

lthls · web-flow · commit 40d69cef868e · 2022-02-22T13:27:46.000Z
* Forbid local function optimisation across functions

* Wrap blocks for shared method arrays in Popaque

* More opacity in Translclass

* Even more opacity around objects

* Promote test

* Refactoring
diff --git a/lambda/simplif.ml b/lambda/simplif.ml
@@ -818,6 +818,7 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body
 type slot =
   {
     func: lfunction;
+    function_scope: lambda;
     mutable scope: lambda option;
   }
 
@@ -836,6 +837,7 @@ let simplify_local_functions lam =
      is in tail position. *)
   let current_scope = ref lam in
   let current_region_scope = ref lam in
+  let current_function_scope = ref lam in
   let check_static lf =
     if lf.attr.local = Always_local then
       Location.prerr_warning (to_location lf.loc)
@@ -854,7 +856,9 @@ let simplify_local_functions lam =
   in
   let rec tail = function
     | Llet (_str, _kind, id, Lfunction lf, cont) when enabled lf.attr ->
-        let r = {func = lf; scope = None} in
+        let r =
+          {func = lf; function_scope = !current_function_scope; scope = None}
+        in
         Hashtbl.add slots id r;
         tail cont;
         begin match Hashtbl.find_opt slots id with
@@ -874,7 +878,7 @@ let simplify_local_functions lam =
         | _ ->
             check_static lf;
             (* note: if scope = None, the function is unused *)
-            non_tail lf.body
+            function_definition lf
         end
     | Lapply {ap_func = Lvar id; ap_args; ap_region_close; _} ->
         let curr_scope =
@@ -890,6 +894,10 @@ let simplify_local_functions lam =
         | Some {scope = Some scope; _} when scope != curr_scope ->
             (* Different "tail scope" *)
             Hashtbl.remove slots id
+        | Some {function_scope = fscope; _}
+          when fscope != !current_function_scope ->
+            (* Different function *)
+            Hashtbl.remove slots id
         | Some ({scope = None; _} as slot) ->
             (* First use of the function: remember the current tail scope *)
             slot.scope <- Some curr_scope
@@ -899,9 +907,9 @@ let simplify_local_functions lam =
         List.iter non_tail ap_args
     | Lvar id ->
         Hashtbl.remove slots id
-    | Lfunction lf as lam ->
+    | Lfunction lf ->
         check_static lf;
-        Lambda.shallow_iter ~tail ~non_tail lam
+        function_definition lf
     | Lregion lam -> region lam
     | lam ->
         Lambda.shallow_iter ~tail ~non_tail lam
@@ -914,6 +922,11 @@ let simplify_local_functions lam =
     tail lam;
     current_scope := !current_region_scope;
     current_region_scope := old_tail_scope
+  and function_definition lf =
+    let old_function_scope = !current_function_scope in
+    current_function_scope := lf.body;
+    non_tail lf.body;
+    current_function_scope := old_function_scope
   and with_scope ~scope lam =
     let old_scope = !current_scope in
     let old_tail_scope = !current_region_scope in
diff --git a/lambda/translclass.ml b/lambda/translclass.ml
@@ -52,17 +52,20 @@ let lapply ap =
       Lapply ap
 
 let mkappl (func, args) =
-  Lapply {
-    ap_loc=Loc_unknown;
-    ap_func=func;
-    ap_args=args;
-    ap_region_close=Rc_normal;
-    ap_mode=Alloc_heap;
-    ap_tailcall=Default_tailcall;
-    ap_inlined=Default_inlined;
-    ap_specialised=Default_specialise;
-    ap_probe=None;
-  };;
+  Lprim
+    (Popaque,
+     [Lapply {
+         ap_loc=Loc_unknown;
+         ap_func=func;
+         ap_args=args;
+         ap_region_close=Rc_normal;
+         ap_mode=Alloc_heap;
+         ap_tailcall=Default_tailcall;
+         ap_inlined=Default_inlined;
+         ap_specialised=Default_specialise;
+         ap_probe=None;
+       }],
+     Loc_unknown);;
 
 let lsequence l1 l2 =
   if l2 = lambda_unit then l1 else Lsequence(l1, l2)
@@ -264,9 +267,11 @@ let output_methods tbl methods lam =
   | [lab; code] ->
       lsequence (mkappl(oo_prim "set_method", [Lvar tbl; lab; code])) lam
   | _ ->
+      let methods =
+        Lprim(Pmakeblock(0,Immutable,None,Alloc_heap), methods, Loc_unknown)
+      in
       lsequence (mkappl(oo_prim "set_methods",
-                        [Lvar tbl; Lprim(Pmakeblock(0,Immutable,None,Alloc_heap),
-                                         methods, Loc_unknown)]))
+                        [Lvar tbl; Lprim (Popaque, [methods], Loc_unknown)]))
         lam
 
 let rec ignore_cstrs cl =
@@ -910,7 +915,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag =
     if inh_keys = [] then Llet(Alias, Pgenval, cached, Lvar tables, lam) else
     Llet(Strict, Pgenval, cached,
          mkappl (oo_prim "lookup_tables",
-                [Lvar tables; Lprim(Pmakeblock(0, Immutable, None, Alloc_heap),
+                [Lvar tables; Lprim(Pmakearray(Paddrarray, Immutable, Alloc_heap),
                                     inh_keys, Loc_unknown)]),
          lam)
   and lset cached i lam =
diff --git a/lambda/translobj.ml b/lambda/translobj.ml
@@ -91,7 +91,11 @@ let transl_label_init_general f =
   let expr, size = f () in
   let expr =
     Hashtbl.fold
-      (fun c id expr -> Llet(Alias, Pgenval, id, Lconst c, expr))
+      (fun c id expr ->
+         let const =
+           Lprim (Popaque, [Lconst c], Debuginfo.Scoped_location.Loc_unknown)
+         in
+         Llet(Alias, Pgenval, id, const, expr))
       consts expr
   in
   (*let expr =
@@ -177,10 +181,13 @@ let oo_wrap env req f x =
          let lambda =
            List.fold_left
              (fun lambda id ->
+                let cl =
+                  Lprim(Pmakeblock(0, Mutable, None, Alloc_heap),
+                        [lambda_unit; lambda_unit; lambda_unit],
+                        Loc_unknown)
+                in
                 Llet(StrictOpt, Pgenval, id,
-                     Lprim(Pmakeblock(0, Mutable, None, Alloc_heap),
-                           [lambda_unit; lambda_unit; lambda_unit],
-                           Loc_unknown),
+                     Lprim (Popaque, [cl], Loc_unknown),
                      lambda))
              lambda !classes
          in
diff --git a/testsuite/tests/functors/functors.compilers.reference b/testsuite/tests/functors/functors.compilers.reference
@@ -20,19 +20,21 @@
        (module-defn(F1) Functors functors.ml(31):516-632
          (function X Y is_a_functor always_inline
            (let
-             (sheep =
+             (cow =
                 (function x[int] : int
-                  (+ 1 (apply (field 0 Y) (apply (field 0 X) x)))))
+                  (apply (field 0 Y) (apply (field 0 X) x)))
+              sheep = (function x[int] : int (+ 1 (apply cow x))))
              (makeblock 0 sheep))))
      F2 =
        (module-defn(F2) Functors functors.ml(36):634-784
          (function X Y is_a_functor always_inline
            (let
              (X =a (makeblock 0 (field 1 X))
               Y =a (makeblock 0 (field 1 Y))
-              sheep =
+              cow =
                 (function x[int] : int
-                  (+ 1 (apply (field 0 Y) (apply (field 0 X) x)))))
+                  (apply (field 0 Y) (apply (field 0 X) x)))
+              sheep = (function x[int] : int (+ 1 (apply cow x))))
              (makeblock 0 sheep))))
      M =
        (module-defn(M) Functors functors.ml(41):786-970
