Mark Obj_dup as not having effects and handle in Cfg (ocaml-flambda#3766)

Author: mshinwell

backend/cfg/cfg.ml

@@ -412,7 +412,13 @@ let can_raise_terminator (i : terminator) =
   | Raise _ | Tailcall_func _ | Call _ | Prim { op = Probe _; label_after = _ }
     ->
     true
-  | Prim { op = External { alloc; _ }; label_after = _ } -> alloc
+  | Prim { op = External { alloc; effects; _ }; label_after = _ } -> (
+    if not alloc
+    then false
+    else
+      (* Even if going via [caml_c_call], if there are no effects, the function
+         cannot raise an exception. (Example: [caml_obj_dup].) *)
+      match effects with No_effects -> false | Arbitrary_effects -> true)
   | Specific_can_raise { op; _ } ->
     assert (Arch.operation_can_raise op);
     true
@@ -423,6 +429,8 @@ let can_raise_terminator (i : terminator) =
 (* CR gyorsh: [is_pure_terminator] is not the same as [can_raise_terminator]
    because of [Tailcal Self] which is not pure but marked as cannot raise at the
    moment, which we might want to reconsider later. *)
+(* CR mshinwell/gyorsh: maybe this function could be made more precise e.g.
+   taking into account [effects] on extcalls *)
 let is_pure_terminator desc =
   match (desc : terminator) with
   | Return | Raise _ | Call_no_return _ | Tailcall_func _ | Tailcall_self _

middle_end/flambda2/to_cmm/to_cmm_primitive.ml

@@ -858,8 +858,8 @@ let unary_primitive env res dbg f arg =
     ( None,
       res,
       C.extcall ~dbg ~alloc:true ~returns:true ~is_c_builtin:false
-        ~effects:Arbitrary_effects ~coeffects:Has_coeffects ~ty_args:[]
-        "caml_obj_dup" Cmm.typ_val [arg] )
+        ~effects:No_effects ~coeffects:Has_coeffects ~ty_args:[] "caml_obj_dup"
+        Cmm.typ_val [arg] )
   | Is_int _ -> None, res, C.and_int arg (C.int ~dbg 1) dbg
   | Is_null -> None, res, C.eq ~dbg arg (C.nativeint ~dbg 0n)
   | Get_tag -> None, res, C.get_tag arg dbg

runtime/obj.c

@@ -154,15 +154,22 @@ CAMLprim value caml_obj_with_tag(value new_tag_v, value arg)
   tag_t tag_for_alloc;
   uintnat infix_offset = 0;
 
+  // This function must not raise exceptions (except asynchronous exceptions).
+  // It behaves just like an allocation function, which has generative effects,
+  // but not arbitrary effects.  (See the [Obj_dup] case in [To_cmm].)
+
   tag_t new_tag = (tag_t)Long_val(new_tag_v);
+#ifdef DEBUG
   tag_t existing_tag = Tag_val(arg);
+#endif
 
-  if ((existing_tag == Closure_tag || existing_tag == Infix_tag
+  CAMLassert (
+    !(
+      (existing_tag == Closure_tag || existing_tag == Infix_tag
        || new_tag == Closure_tag || new_tag == Infix_tag)
-      && existing_tag != new_tag) {
-    caml_failwith("Cannot change tags of existing closures or create \
-      new closures using [caml_obj_with_tag]");
-  }
+      && existing_tag != new_tag));
+  // Cannot change tags of existing closures or create new closures using
+  // [caml_obj_with_tag].
 
   if (new_tag == Infix_tag) {
     // If we received an infix block, we must return the same; but the whole

runtime4/obj.c

@@ -159,15 +159,22 @@ CAMLprim value caml_obj_with_tag(value new_tag_v, value arg)
   tag_t tag_for_alloc;
   uintnat infix_offset = 0;
 
+  // This function must not raise exceptions (except asynchronous exceptions).
+  // It behaves just like an allocation function, which has generative effects,
+  // but not arbitrary effects.  (See the [Obj_dup] case in [To_cmm].)
+
   tag_t new_tag = (tag_t)Long_val(new_tag_v);
+#ifdef DEBUG
   tag_t existing_tag = Tag_val(arg);
+#endif
 
-  if ((existing_tag == Closure_tag || existing_tag == Infix_tag
+  CAMLassert (
+    !(
+      (existing_tag == Closure_tag || existing_tag == Infix_tag
        || new_tag == Closure_tag || new_tag == Infix_tag)
-      && existing_tag != new_tag) {
-    caml_failwith("Cannot change tags of existing closures or create \
-      new closures using [caml_obj_with_tag]");
-  }
+      && existing_tag != new_tag));
+  // Cannot change tags of existing closures or create new closures using
+  // [caml_obj_with_tag].
 
   if (new_tag == Infix_tag) {
     // If we received an infix block, we must return the same; but the whole

testsuite/tests/exception-extra-args/obj_dup.ml

@@ -0,0 +1,20 @@
+(* TEST *)
+
+[@@@ocaml.flambda_o3]
+
+let[@inline never] bar _ _ = ()
+
+let[@inline never] baz () = ()
+
+let foo size (x : int) arr y =
+  let extra_arg_array = ref arr in
+  let extra_arg_int = ref 0 in
+  (try
+    for i = 0 to size - 1 do
+      if i > 20 then (
+        let _ = Sys.opaque_identity (Obj.dup y) in
+        baz ()
+      )
+    done
+  with _exn -> ());
+  bar !extra_arg_array !extra_arg_int