flambda-backend: Enable Stdlib.Effect + add Flambda 2 support (#2205)

Author: mshinwell

asmcomp/cmmgen.ml

@@ -955,17 +955,15 @@ and transl_prim_1 env p arg dbg =
   | Pget_header m ->
       box_int dbg Pnativeint m (get_header (transl env arg) dbg)
   | Pperform ->
-      Misc.fatal_error "Effects-related primitives not yet supported"
-      (* CR mshinwell: use [Runtimetags] once available
       let cont =
-        make_alloc dbg cont_tag [int_const dbg 0] ~mode:Lambda.alloc_heap
+        make_alloc dbg Runtimetags.cont_tag [int_const dbg 0]
+          ~mode:Lambda.alloc_heap
       in
-      (* CR mshinwell: Rc_normal may be wrong, but this code is unlikely
-         to be in production by then *)
-      Cop(Capply (typ_val, Rc_normal),
+      (* Rc_normal means "allow tailcalls".  Preventing them here by using
+         Rc_nontail improves backtraces of paused fibers. *)
+      Cop(Capply (typ_val, Rc_nontail),
        [Cconst_symbol ("caml_perform", dbg); transl env arg; cont],
        dbg)
-      *)
   | Pdls_get ->
       Cop(Cdls_get, [transl env arg], dbg)
   | Patomic_load {immediate_or_pointer = Immediate} ->
@@ -1264,35 +1262,28 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg =
 
   (* Effects *)
   | Presume ->
-      Misc.fatal_error "Effects-related primitives not yet supported"
-      (*
-      (* CR mshinwell: Rc_normal may be wrong, but this code is unlikely
-         to be in production by then *)
+      (* Rc_normal is required here, because there are some usages of effects
+         with repeated resumes, and these should consume O(1) stack space by
+         tail-calling caml_resume. *)
       Cop (Capply (typ_val, Rc_normal),
            [Cconst_symbol ("caml_resume", dbg);
            transl env arg1; transl env arg2; transl env arg3],
            dbg)
-      *)
   | Prunstack ->
-      Misc.fatal_error "Effects-related primitives not yet supported"
-      (*
-      (* CR mshinwell: Rc_normal may be wrong, but this code is unlikely
-         to be in production by then *)
-      Cop (Capply (typ_val, Rc_normal),
+      (* Rc_normal is fine here but unlikely to ever be a tail call (usages
+         of this primitive shouldn't be generated in tail position), so
+         we use Rc_nontail for clarity. *)
+      Cop (Capply (typ_val, Rc_nontail),
            [Cconst_symbol ("caml_runstack", dbg);
            transl env arg1; transl env arg2; transl env arg3],
            dbg)
-      *)
   | Preperform ->
-      Misc.fatal_error "Effects-related primitives not yet supported"
-      (*
-      (* CR mshinwell: Rc_normal may be wrong, but this code is unlikely
-         to be in production by then *)
+      (* Rc_normal is required here, this is used in tail position and should
+         tail call. *)
       Cop (Capply (typ_val, Rc_normal),
            [Cconst_symbol ("caml_reperform", dbg);
            transl env arg1; transl env arg2; transl env arg3],
            dbg)
-      *)
 
   | Pperform | Pdls_get
   | Patomic_exchange | Patomic_fetch_add | Patomic_load _

bytecomp/emitcode.ml

@@ -205,6 +205,10 @@ and emit_branch_comp = function
 | Clt -> out opBLTINT | Cle -> out opBLEINT
 | Cgt -> out opBGTINT | Cge -> out opBGEINT
 
+let runtime5_only () =
+  if not Config.runtime5 then
+    Misc.fatal_error "Effect primitives are only supported on runtime5"
+
 let emit_instr = function
     Klabel lbl -> define_label lbl
   | Kacc n ->
@@ -311,17 +315,11 @@ let emit_instr = function
   | Kgetpubmet tag -> out opGETPUBMET; out_int tag; out_int 0
   | Kgetdynmet -> out opGETDYNMET
   | Kevent ev -> record_event ev
-  (* CR mshinwell: enable for effects support
-  | Kperform -> out opPERFORM
-  | Kresume -> out opRESUME
-  | Kresumeterm n -> out opRESUMETERM; out_int n
-  | Kreperformterm n -> out opREPERFORMTERM; out_int n
-  | Kstop -> out opSTOP *)
-  | Kperform
-  | Kresume
-  | Kresumeterm _
-  | Kreperformterm _
-  | Kstop -> Misc.fatal_error "No effects support provided yet"
+  | Kperform -> runtime5_only (); out opPERFORM
+  | Kresume -> runtime5_only (); out opRESUME
+  | Kresumeterm n -> runtime5_only (); out opRESUMETERM; out_int n
+  | Kreperformterm n -> runtime5_only (); out opREPERFORMTERM; out_int n
+  | Kstop -> out opSTOP
 
 (* Emission of a list of instructions. Include some peephole optimization. *)
 

lambda/lambda.ml

@@ -1785,7 +1785,8 @@ let primitive_may_allocate : primitive -> alloc_mode option = function
   | Punbox_float _ | Punbox_int _ -> None
   | Pbox_float (_, m) | Pbox_int (_, m) -> Some m
   | Prunstack | Presume | Pperform | Preperform ->
-    Misc.fatal_error "Effects-related primitives are not yet supported"
+    (* CR mshinwell: check *)
+    Some alloc_heap
   | Patomic_load _
   | Patomic_exchange
   | Patomic_cas
@@ -1960,9 +1961,7 @@ let primitive_result_layout (p : primitive) =
       layout_any_value
   | (Parray_to_iarray | Parray_of_iarray) -> layout_any_value
   | Pget_header _ -> layout_boxedint Pnativeint
-  | Prunstack | Presume | Pperform | Preperform ->
-    (* CR mshinwell/ncourant: to be thought about later *)
-    Misc.fatal_error "Effects-related primitives are not yet supported"
+  | Prunstack | Presume | Pperform | Preperform -> layout_any_value
   | Patomic_load { immediate_or_pointer = Immediate } -> layout_int
   | Patomic_load { immediate_or_pointer = Pointer } -> layout_any_value
   | Patomic_exchange

lambda/translprim.ml

@@ -94,6 +94,7 @@ type prim =
   | Identity
   | Apply of Lambda.region_close * Lambda.layout
   | Revapply of Lambda.region_close * Lambda.layout
+  | Unsupported of Lambda.primitive
 
 let units_with_used_primitives = Hashtbl.create 7
 let add_used_primitive loc env path =
@@ -180,6 +181,7 @@ let to_lambda_prim prim ~poly_sort =
     ~is_layout_poly:prim.prim_is_layout_poly
 
 let lookup_primitive loc ~poly_mode ~poly_sort pos p =
+  let runtime5 = Config.runtime5 in
   let mode = to_locality ~poly:poly_mode p.prim_native_repr_res in
   let arg_modes =
     List.map (to_modify_mode ~poly:poly_mode) p.prim_native_repr_args
@@ -710,10 +712,14 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p =
     | "%atomic_exchange" -> Primitive (Patomic_exchange, 2)
     | "%atomic_cas" -> Primitive (Patomic_cas, 3)
     | "%atomic_fetch_add" -> Primitive (Patomic_fetch_add, 2)
-    | "%runstack" -> Primitive (Prunstack, 3)
-    | "%reperform" -> Primitive (Preperform, 3)
-    | "%perform" -> Primitive (Pperform, 1)
-    | "%resume" -> Primitive (Presume, 3)
+    | "%runstack" ->
+      if runtime5 then Primitive (Prunstack, 3) else Unsupported Prunstack
+    | "%reperform" ->
+      if runtime5 then Primitive (Preperform, 3) else Unsupported Preperform
+    | "%perform" ->
+      if runtime5 then Primitive (Pperform, 1) else Unsupported Pperform
+    | "%resume" ->
+      if runtime5 then Primitive (Presume, 3) else Unsupported Presume
     | "%dls_get" -> Primitive (Pdls_get, 1)
     | "%unbox_nativeint" -> Primitive(Punbox_int Pnativeint, 1)
     | "%box_nativeint" -> Primitive(Pbox_int (Pnativeint, mode), 1)
@@ -1268,6 +1274,21 @@ let lambda_of_prim prim_name prim loc args arg_exps =
         ap_region_close = pos;
         ap_mode = alloc_heap;
       }
+  | Unsupported prim, _ ->
+      let exn =
+        transl_extension_path loc (Lazy.force Env.initial)
+          Predef.path_invalid_argument
+      in
+      let msg =
+        Format.asprintf "Unsupported primitive %a" Printlambda.primitive prim
+      in
+      Lprim (
+        Praise Raise_regular,
+        [Lprim (
+          Pmakeblock (0, Immutable, None, alloc_heap),
+          [exn; Lconst (Const_immstring msg)],
+          loc)],
+        loc)
   | (Raise _ | Raise_with_backtrace
     | Lazy_force _ | Loc _ | Primitive _ | Sys_argv | Comparison _
     | Send _ | Send_self _ | Send_cache _ | Frame_pointers | Identity
@@ -1305,6 +1326,7 @@ let check_primitive_arity loc p =
     | Frame_pointers -> p.prim_arity = 0
     | Identity -> p.prim_arity = 1
     | Apply _ | Revapply _ -> p.prim_arity = 2
+    | Unsupported _ -> true
   in
   if not ok then raise(Error(loc, Wrong_arity_builtin_primitive p.prim_name))
 
@@ -1488,7 +1510,8 @@ let primitive_needs_event_after = function
       lambda_primitive_needs_event_after (comparison_primitive comp knd)
   | Lazy_force _ | Send _ | Send_self _ | Send_cache _
   | Apply _ | Revapply _ -> true
-  | Raise _ | Raise_with_backtrace | Loc _ | Frame_pointers | Identity -> false
+  | Raise _ | Raise_with_backtrace | Loc _ | Frame_pointers | Identity
+  | Unsupported _ -> false
 
 let transl_primitive_application loc p env ty ~poly_mode ~poly_sort
     path exp args arg_exps pos =

middle_end/clambda_primitives.ml

@@ -323,8 +323,7 @@ let result_layout (p : primitive) =
     Lambda.layout_any_value
   | Pget_header _ -> Lambda.layout_boxedint Pnativeint
   | Prunstack | Presume | Pperform | Preperform ->
-    (* CR mshinwell/ncourant: to be thought about later *)
-    Misc.fatal_error "Effects-related primitives are not yet supported"
+    Lambda.layout_any_value
   | Patomic_load { immediate_or_pointer = Immediate } -> Lambda.layout_int
   | Patomic_load { immediate_or_pointer = Pointer } -> Lambda.layout_any_value
   | Patomic_exchange

runtime4/caml/instruct.h

@@ -61,6 +61,7 @@ enum instructions {
   EVENT, BREAK,
   RERAISE, RAISE_NOTRACE,
   GETSTRINGCHAR,
+  PERFORM, RESUME, RESUMETERM, REPERFORMTERM,
   MAKE_FAUX_MIXEDBLOCK,
 FIRST_UNIMPLEMENTED_OP};
 

runtime4/interp.c

@@ -1223,6 +1223,12 @@ value caml_interprete(code_t prog, asize_t prog_size)
       Restore_after_debugger;
       Restart_curr_instr;
 
+    Instruct(PERFORM):
+    Instruct(RESUME):
+    Instruct(RESUMETERM):
+    Instruct(REPERFORMTERM):
+      caml_fatal_error("Effect primitives not supported on runtime4");
+
 #ifndef THREADED_CODE
     default:
 #if _MSC_VER >= 1200

runtime4/misc.c

@@ -273,3 +273,25 @@ CAMLprim value caml_atomic_fetch_add(value ref, value incr)
   *p = Val_long(Long_val(ret) + Long_val(incr));
   return ret;
 }
+
+// Dummy implementations so effect.ml can compile
+
+CAMLprim value caml_continuation_use_noexc(void)
+{
+  caml_fatal_error("Effects not implemented in runtime4");
+}
+
+CAMLprim value caml_alloc_stack(void)
+{
+  caml_fatal_error("Effects not implemented in runtime4");
+}
+
+CAMLprim value caml_get_continuation_callstack(void)
+{
+  caml_fatal_error("Effects not implemented in runtime4");
+}
+
+CAMLprim value caml_continuation_use_and_update_handler_noexc(void)
+{
+  caml_fatal_error("Effects not implemented in runtime4");
+}

stdlib/effect.ml

@@ -1,3 +1,4 @@
+# 1 "effect.ml"
 (**************************************************************************)
 (*                                                                        *)
 (*                                 OCaml                                  *)
@@ -12,10 +13,6 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* CR mshinwell: To be re-enabled in due course *)
-
-(*
-
 type 'a t = ..
 external perform : 'a t -> 'a = "%perform"
 
@@ -163,5 +160,3 @@ module Shallow = struct
     ('a,'b) continuation -> int -> Printexc.raw_backtrace =
     "caml_get_continuation_callstack"
 end
-
-*)

stdlib/effect.mli

@@ -1,3 +1,4 @@
+# 1 "effect.mli"
 (**************************************************************************)
 (*                                                                        *)
 (*                                 OCaml                                  *)
@@ -12,10 +13,6 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* CR mshinwell: To be re-enabled in due course *)
-
-(*
-
 [@@@alert unstable
     "The Effect interface may change in incompatible ways in the future."
 ]
@@ -149,5 +146,3 @@ module Shallow : sig
   (** [get_callstack c n] returns a description of the top of the call stack on
       the continuation [c], with at most [n] entries. *)
 end
-
-*)

stdlib/stdlib.ml

@@ -608,10 +608,7 @@ module Complex        = Complex
 module Condition      = Condition
 module Digest         = Digest
 module Domain         = Domain
-(* CR ocaml 5 effects:
-   BACKPORT
 module Effect         = Effect
-*)
 module Either         = Either
 module Ephemeron      = Ephemeron
 module Filename       = Filename

stdlib/stdlib.mli

@@ -1410,14 +1410,10 @@ module Domain         = Domain
 [@@alert unstable
     "The Domain interface may change in incompatible ways in the future."
 ]
-(* CR ocaml 5 effects:
-BACKPORT
 module Effect         = Effect
-[@@alert "-unstable"]
 [@@alert unstable
     "The Effect interface may change in incompatible ways in the future."
 ]
-*)
 module Either         = Either
 module Ephemeron      = Ephemeron
 module Filename       = Filename