Add the opaque primitive

Author: chambart

asmcomp/cmmgen.ml

@@ -1698,7 +1698,7 @@ and transl_ccall env prim args dbg =
 and transl_prim_1 env p arg dbg =
   match p with
   (* Generic operations *)
-    Pidentity ->
+    Pidentity | Popaque ->
       transl env arg
   | Pignore ->
       return_unit(remove_unit (transl env arg))

bytecomp/bytegen.ml

@@ -571,7 +571,7 @@ let rec comp_expr env exp sz cont =
         in
         comp_init env sz decl_size
       end
-  | Lprim(Pidentity, [arg]) ->
+  | Lprim((Pidentity | Popaque), [arg]) ->
       comp_expr env arg sz cont
   | Lprim(Pignore, [arg]) ->
       comp_expr env arg sz (add_const_unit cont)

bytecomp/lambda.ml

@@ -133,6 +133,8 @@ type primitive =
   | Pbbswap of boxed_integer
   (* Integer to external pointer *)
   | Pint_as_pointer
+  (* Inhibition of optimisation *)
+  | Popaque
 
 and comparison =
     Ceq | Cneq | Clt | Cgt | Cle | Cge

bytecomp/lambda.mli

@@ -136,6 +136,8 @@ type primitive =
   | Pbbswap of boxed_integer
   (* Integer to external pointer *)
   | Pint_as_pointer
+  (* Inhibition of optimisation *)
+  | Popaque
 
 and comparison =
     Ceq | Cneq | Clt | Cgt | Cle | Cge

bytecomp/printlambda.ml

@@ -260,6 +260,7 @@ let primitive ppf = function
   | Pbswap16 -> fprintf ppf "bswap16"
   | Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi
   | Pint_as_pointer -> fprintf ppf "int_as_pointer"
+  | Popaque -> fprintf ppf "opaque"
 
 let name_of_primitive = function
   | Pidentity -> "Pidentity"
@@ -354,6 +355,7 @@ let name_of_primitive = function
   | Pbswap16 -> "Pbswap16"
   | Pbbswap _ -> "Pbbswap"
   | Pint_as_pointer -> "Pint_as_pointer"
+  | Popaque -> "Popaque"
 
 let function_attribute ppf { inline; is_a_functor } =
   if is_a_functor then

bytecomp/translcore.ml

@@ -297,6 +297,7 @@ let primitives_table = create_hashtable 57 [
   "%bswap_int64", Pbbswap(Pint64);
   "%bswap_native", Pbbswap(Pnativeint);
   "%int_as_pointer", Pint_as_pointer;
+  "%opaque", Popaque;
 ]
 
 let prim_obj_dup =

otherlibs/threads/pervasives.ml

@@ -597,6 +597,10 @@ let (^^) (Format (fmt1, str1)) (Format (fmt2, str2)) =
   Format (CamlinternalFormatBasics.concat_fmt fmt1 fmt2,
           str1 ^ "%," ^ str2)
 
+(* Optimisation *)
+
+external opaque : 'a -> 'a = "%opaque"
+
 (* Miscellaneous *)
 
 external sys_exit : int -> 'a = "caml_sys_exit"

stdlib/pervasives.ml

@@ -502,6 +502,10 @@ let ( ^^ ) (Format (fmt1, str1)) (Format (fmt2, str2)) =
   Format (CamlinternalFormatBasics.concat_fmt fmt1 fmt2,
           str1 ^ "%," ^ str2)
 
+(* Optimisation *)
+
+external opaque : 'a -> 'a = "%opaque"
+
 (* Miscellaneous *)
 
 external sys_exit : int -> 'a = "caml_sys_exit"

stdlib/pervasives.mli

@@ -1098,6 +1098,14 @@ val ( ^^ ) :
   [f1], then results from [f2].
 *)
 
+(** {6 Optimisation} *)
+
+external opaque : 'a -> 'a = "%opaque"
+(** Semantically, [opaque v] behaves as the identity function; but when
+    used with Flambda mode, for the purposes of optimisation passes such
+    expression is side-effecting and yields an unknown result.  This may
+    be used to prevent necessary code in applications such as benchmarks from
+    being optimised away. *)
 
 (** {6 Program termination} *)
 

testsuite/tests/basic-more/opaque_prim.ml

@@ -0,0 +1,8 @@
+
+let f x = opaque x
+
+let () =
+  assert(f f == f);
+  assert(opaque 1 = 1);
+  assert(opaque 1. = 1.)
+

testsuite/tests/basic-more/opaque_prim.reference

@@ -0,0 +1,2 @@
+
+All tests succeeded.