melange-re · anmonteiro · Feb 16, 2025 · Jan 3, 2025 · Jan 4, 2025 · Jan 5, 2025
diff --git a/Changes.md b/Changes.md
@@ -1,3 +1,9 @@
+Unreleased
+---------------
+
+- Support `Sys.opaque_identity` to turn off optimizations
+  ([#1276](https://github.com/melange-re/melange/pull/1276))
+
 5.0.0-53
 ---------------
 

diff --git a/flake.lock b/flake.lock
diff --git a/jscomp/core/lam_analysis.ml b/jscomp/core/lam_analysis.ml
@@ -122,7 +122,7 @@ let rec no_side_effects (lam : Lam.t) : bool =
       | Parraysets
       (* byte swap *)
       | Pbswap16 | Pbbswap _ | Parraysetu | Poffsetref _ | Praise | Plazyforce
-      | Psetfield _ | Psetfield_computed ->
+      | Psetfield _ | Psetfield_computed | Popaque ->
           false)
   | Llet (_, _, arg, body) | Lmutlet (_, arg, body) ->
       no_side_effects arg && no_side_effects body

diff --git a/jscomp/core/lam_compile.ml b/jscomp/core/lam_compile.ml
@@ -1634,9 +1634,17 @@ and compile_prim (prim_info : Lam.prim_info)
      [
        Lprim
          {
-           primitive =
-             Pjs_unsafe_downgrade { name = property; setter = true; _ };
-           args = [ obj ];
+           primitive = Popaque;
+           args =
+             [
+               Lprim
+                 {
+                   primitive =
+                     Pjs_unsafe_downgrade { name = property; setter = true; _ };
+                   args = [ obj ];
+                   _;
+                 };
+             ];
            _;
          };
        setter_val;
@@ -1663,7 +1671,16 @@ and compile_prim (prim_info : Lam.prim_info)
   | {
    primitive = Pfull_apply;
    args =
-     Lprim { primitive = Pjs_unsafe_downgrade { setter = true; _ }; _ } :: _;
+     Lprim
+       {
+         primitive = Popaque;
+         args =
+           [
+             Lprim { primitive = Pjs_unsafe_downgrade { setter = true; _ }; _ };
+           ];
+         _;
+       }
+     :: _;
    _;
   } ->
       assert false
@@ -1678,19 +1695,52 @@ and compile_prim (prim_info : Lam.prim_info)
       (* It's a bit sad that we have to match specifically on the output of
          `Lam_ffi.result_wrap` to handle the case of result wrapping for
          uncurried externals. *)
-      | Lprim
-          {
-            primitive =
-              Pjs_call
-                { ffi = Js_call _ | Js_send _ | Js_get _ | Js_get_index _; _ }
-              as primitive;
-            args = [];
-            loc;
-          }
+      | ( Lprim
+            {
+              primitive =
+                Pjs_call
+                  { ffi = Js_call _ | Js_send _ | Js_get _ | Js_get_index _; _ }
+                as primitive;
+              args = [];
+              loc;
+            }
+        | Lprim
+            {
+              primitive = Popaque;
+              args =
+                [
+                  Lprim
+                    {
+                      primitive =
+                        Pjs_call
+                          {
+                            ffi =
+                              Js_call _ | Js_send _ | Js_get _ | Js_get_index _;
+                            _;
+                          } as primitive;
+                      args = [];
+                      loc;
+                    };
+                ];
+              _;
+            } )
         :: rest ->
           compile_lambda lambda_cxt (Lam.prim ~primitive ~args:rest loc)
-      | Lsequence
-          (Lprim { primitive = Pjs_call _ as primitive; args = []; loc }, l2)
+      | ( Lprim
+            {
+              primitive = Popaque;
+              args =
+                [
+                  Lsequence
+                    ( Lprim
+                        { primitive = Pjs_call _ as primitive; args = []; loc },
+                      l2 );
+                ];
+              _;
+            }
+        | Lsequence
+            (Lprim { primitive = Pjs_call _ as primitive; args = []; loc }, l2)
+          )
         :: rest ->
           let output_l1 =
             compile_lambda
@@ -1699,15 +1749,41 @@ and compile_prim (prim_info : Lam.prim_info)
           in
           let output_l2 = compile_lambda lambda_cxt l2 in
           Js_output.append_output output_l1 output_l2
-      | Lprim
-          {
-            primitive =
-              (Pnull_to_opt | Pnull_undefined_to_opt | Pundefined_to_opt) as
-              nu_prim;
-            args =
-              [ Lprim { primitive = Pjs_call _ as primitive; args = []; loc } ];
-            loc = nu_loc;
-          }
+      | ( Lprim
+            {
+              primitive =
+                (Pnull_to_opt | Pnull_undefined_to_opt | Pundefined_to_opt) as
+                nu_prim;
+              args =
+                [
+                  Lprim { primitive = Pjs_call _ as primitive; args = []; loc };
+                ];
+              loc = nu_loc;
+            }
+        | Lprim
+            {
+              primitive = Popaque;
+              args =
+                [
+                  Lprim
+                    {
+                      primitive =
+                        ( Pnull_to_opt | Pnull_undefined_to_opt
+                        | Pundefined_to_opt ) as nu_prim;
+                      args =
+                        [
+                          Lprim
+                            {
+                              primitive = Pjs_call _ as primitive;
+                              args = [];
+                              loc;
+                            };
+                        ];
+                      loc = nu_loc;
+                    };
+                ];
+              _;
+            } )
         :: rest ->
           compile_lambda lambda_cxt
             (Lam.prim ~primitive:nu_prim

diff --git a/jscomp/core/lam_compile_primitive.ml b/jscomp/core/lam_compile_primitive.ml
@@ -367,6 +367,7 @@ let translate loc (cxt : Lam_compile_context.t) (prim : Lam_primitive.t)
   | Pbbswap Pint32 ->
       E.runtime_call ~module_name:Js_runtime_modules.bytes ~fn_name:"bswap32"
         args
+  | Popaque -> List.hd args
   | Pbbswap Pint64 ->
       E.runtime_call ~module_name:Js_runtime_modules.bytes ~fn_name:"bswap64"
         args

diff --git a/jscomp/core/lam_convert.cppo.ml b/jscomp/core/lam_convert.cppo.ml
@@ -433,7 +433,7 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t =
       | Pnativeint | Pint32 -> Lam.prim ~primitive:(Pintcomp b) ~args loc
       | Pint64 -> Lam.prim ~primitive:(Pint64comp b) ~args loc)
   | Pfield_computed -> Lam.prim ~primitive:Pfield_computed ~args loc
-  | Popaque -> List.hd args
+  | Popaque -> Lam.prim ~primitive:Popaque ~args loc
   | Psetfield_computed _ -> Lam.prim ~primitive:Psetfield_computed ~args loc
   | Pbbswap i -> Lam.prim ~primitive:(Pbbswap i) ~args loc
   | Pbswap16 -> Lam.prim ~primitive:Pbswap16 ~args loc

diff --git a/jscomp/core/lam_pass_remove_alias.ml b/jscomp/core/lam_pass_remove_alias.ml
@@ -57,6 +57,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t =
               (fun _ -> Lam.prim ~primitive ~args:[ l ] loc)
               v i info meta.ident_tbl
         | l -> Lam.prim ~primitive ~args:[ l ] loc)
+    | Lprim { primitive = Popaque; _ } -> lam
     | Lprim
         {
           primitive = (Pval_from_option | Pval_from_option_not_nest) as p;

diff --git a/jscomp/core/lam_primitive.ml b/jscomp/core/lam_primitive.ml
@@ -149,6 +149,9 @@ type t =
       Lam_compat.compile_time_constant (* Integer to external pointer *)
   | Pbswap16
   | Pbbswap of Lam_compat.boxed_integer
+  (* Inhibition of optimisation *)
+  | Popaque
+  (* JS specific *)
   | Pdebugger
   | Pjs_unsafe_downgrade of { name : string; setter : bool; loc : Location.t }
   | Pinit_mod
@@ -372,6 +375,7 @@ let eq_primitive_approx (lhs : t) (rhs : t) =
       | _ -> false)
   | Pbswap16 -> rhs = Pbswap16
   | Pbbswap i1 -> ( match rhs with Pbbswap i2 -> i1 = i2 | _ -> false)
+  | Popaque -> ( match rhs with Popaque -> true | _ -> false)
   | Pjs_unsafe_downgrade { name; loc = _; setter } -> (
       match rhs with
       | Pjs_unsafe_downgrade rhs -> name = rhs.name && setter = rhs.setter

diff --git a/jscomp/core/lam_primitive.mli b/jscomp/core/lam_primitive.mli
@@ -141,6 +141,8 @@ type t =
   | Pctconst of Lam_compat.compile_time_constant
   | Pbswap16
   | Pbbswap of Lam_compat.boxed_integer
+  (* Inhibition of optimisation *)
+  | Popaque
   (* Integer to external pointer *)
   | Pdebugger
   | Pjs_unsafe_downgrade of { name : string; setter : bool; loc : Location.t }

diff --git a/jscomp/core/lam_print.ml b/jscomp/core/lam_print.ml
@@ -190,6 +190,7 @@ let primitive ppf (prim : Lam_primitive.t) =
   | Pbbswap Pnativeint -> fprintf ppf "bswap_nativeint"
   | Pbbswap Pint32 -> fprintf ppf "bswap32"
   | Pbbswap Pint64 -> fprintf ppf "bswap64"
+  | Popaque -> fprintf ppf "opaque"
   | Pisint -> fprintf ppf "isint"
   | Pis_poly_var_const -> fprintf ppf "#is_poly_var_const"
   | Pisout i -> fprintf ppf "isout %d" i

diff --git a/jscomp/test/arity_deopt.ml → jscomp/test/arity_deopt_test.ml b/jscomp/test/arity_deopt.ml → jscomp/test/arity_deopt_test.ml
diff --git a/jscomp/test/dist/jscomp/test/arity_deopt.js → ...test/dist/jscomp/test/arity_deopt_test.js b/jscomp/test/dist/jscomp/test/arity_deopt.js → ...test/dist/jscomp/test/arity_deopt_test.js
diff --git a/jscomp/test/dist/jscomp/test/js_obj_test.js b/jscomp/test/dist/jscomp/test/js_obj_test.js
diff --git a/jscomp/test/dist/jscomp/test/ppx_apply_test.js b/jscomp/test/dist/jscomp/test/ppx_apply_test.js
diff --git a/jscomp/test/dist/jscomp/test/unsafe_full_apply_primitive.js b/jscomp/test/dist/jscomp/test/unsafe_full_apply_primitive.js
diff --git a/test/blackbox-tests/opaque.t b/test/blackbox-tests/opaque.t
@@ -0,0 +1,33 @@
+
+  $ . ./setup.sh
+  $ cat > x.ml <<EOF
+  > let pure x = x + 1
+  > let x () =
+  >   for _round = 1 to 10 do
+  >     ignore (Sys.opaque_identity (pure 2))
+  >   done
+  > let () = x ()
+  > EOF
+
+  $ melc -ppx melppx x.ml
+  // Generated by Melange
+  'use strict';
+
+
+  function pure(x) {
+    return x + 1 | 0;
+  }
+
+  function x(param) {
+    for (let _round = 1; _round <= 10; ++_round) {
+      pure(2);
+    }
+  }
+
+  x(undefined);
+
+  module.exports = {
+    pure,
+    x,
+  }
+  /*  Not a pure module */