Enable Stdlib.Effect + add middle and backend support

backend/cmm_helpers.ml

@@ -3601,3 +3601,40 @@ let atomic_compare_and_set ~dbg atomic ~old_value ~new_value =
         },
       [atomic; old_value; new_value],
       dbg )
+
+let perform ~dbg eff =
+  let cont =
+    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),
+      [Cconst_symbol (Cmm.global_symbol "caml_perform", dbg); eff; cont],
+      dbg )
+
+let run_stack ~dbg ~stack ~f ~arg =
+  (* CR mshinwell: Check Rc_normal *)
+  Cop
+    ( Capply (typ_val, Rc_normal),
+      [Cconst_symbol (Cmm.global_symbol "caml_runstack", dbg); stack; f; arg],
+      dbg )
+
+let resume ~dbg ~stack ~f ~arg =
+  (* CR mshinwell: Check Rc_normal *)
+  Cop
+    ( Capply (typ_val, Rc_normal),
+      [Cconst_symbol (Cmm.global_symbol "caml_resume", dbg); stack; f; arg],
+      dbg )
+
+let reperform ~dbg ~eff ~cont ~last_fiber =
+  (* CR mshinwell: Check Rc_normal *)
+  Cop
+    ( Capply (typ_val, Rc_normal),
+      [ Cconst_symbol (Cmm.global_symbol "caml_reperform", dbg);
+        eff;
+        cont;
+        last_fiber ],
+      dbg )

backend/cmm_helpers.mli

@@ -888,3 +888,26 @@ val atomic_compare_and_set :
   expression
 
 val emit_gc_roots_table : symbols:symbol list -> phrase list -> phrase list
+
+val perform : dbg:Debuginfo.t -> expression -> expression
+
+val run_stack :
+  dbg:Debuginfo.t ->
+  stack:expression ->
+  f:expression ->
+  arg:expression ->
+  expression
+
+val resume :
+  dbg:Debuginfo.t ->
+  stack:expression ->
+  f:expression ->
+  arg:expression ->
+  expression
+
+val reperform :
+  dbg:Debuginfo.t ->
+  eff:expression ->
+  cont:expression ->
+  last_fiber:expression ->
+  expression

middle_end/flambda2/from_lambda/closure_conversion.ml

@@ -389,10 +389,11 @@ module Inlining = struct
     let callee = Apply.callee apply in
     let region_inlined_into =
       match Apply.call_kind apply with
-      | Function { alloc_mode; _ } | Method { alloc_mode; _ } -> alloc_mode
-      | C_call _ ->
+      | Function { alloc_mode; _ } -> alloc_mode
+      | Method _ | C_call _ | Effect _ ->
         Misc.fatal_error
-          "Trying to call [Closure_conversion.Inlining.inline] on a C call."
+          "Trying to call [Closure_conversion.Inlining.inline] on a non-OCaml \
+           function call."
     in
     let args = Apply.args apply in
     let apply_return_continuation = Apply.continuation apply in
@@ -487,10 +488,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds
   in
   let cost_metrics_of_body, free_names_of_body, acc, body =
     Acc.measure_cost_metrics acc ~f:(fun acc ->
-        k acc
-          (List.map
-             (fun var -> Named.create_simple (Simple.var var))
-             let_bound_vars))
+        k acc (List.map Named.create_var let_bound_vars))
   in
   let box_return_value =
     match prim_native_repr_res with
@@ -730,6 +728,80 @@ let close_raise acc env ~raise_kind ~arg ~dbg exn_continuation =
   let acc, arg = find_simple acc env arg in
   close_raise0 acc env ~raise_kind ~arg ~dbg exn_continuation
 
+let close_effect_primitive acc env ~dbg exn_continuation
+    (prim : Lambda.primitive) ~args ~let_bound_ids_with_kinds
+    (k : Acc.t -> Named.t list -> Expr_with_acc.t) : Expr_with_acc.t =
+  if not Config.runtime5
+  then Misc.fatal_error "Effect primitives are only supported on runtime5";
+  (* CR mshinwell: share with close_c_call, above *)
+  let _env, let_bound_vars =
+    List.fold_left_map
+      (fun env (id, kind) -> Env.add_var_like env id Not_user_visible kind)
+      env let_bound_ids_with_kinds
+  in
+  let let_bound_var =
+    match let_bound_vars with
+    | [let_bound_var] -> let_bound_var
+    | [] | _ :: _ :: _ ->
+      Misc.fatal_errorf
+        "close_effect_primitive: expected singleton return for primitive %a, \
+         but got: [%a]"
+        Printlambda.primitive prim
+        (Format.pp_print_list ~pp_sep:Format.pp_print_space Variable.print)
+        let_bound_vars
+  in
+  let continuation = Continuation.create () in
+  let return_kind = Flambda_kind.With_subkind.any_value in
+  let params =
+    [BP.create let_bound_var return_kind] |> Bound_parameters.create
+  in
+  let close call_kind =
+    let apply acc =
+      Apply_expr.create ~callee:None ~continuation:(Return continuation)
+        exn_continuation ~args:[] ~args_arity:Flambda_arity.nullary
+        ~return_arity:
+          (Flambda_arity.create_singletons
+             [Flambda_kind.With_subkind.any_value])
+        ~call_kind dbg ~inlined:Never_inlined
+        ~inlining_state:(Inlining_state.default ~round:0)
+        ~probe:None ~position:Normal
+        ~relative_history:Inlining_history.Relative.empty
+      |> Expr_with_acc.create_apply acc
+    in
+    Let_cont_with_acc.build_non_recursive acc continuation
+      ~handler_params:params
+      ~handler:(fun acc ->
+        let cost_metrics_of_body, free_names_of_body, acc, code_after_call =
+          Acc.measure_cost_metrics acc ~f:(fun acc ->
+              k acc (List.map Named.create_var let_bound_vars))
+        in
+        let acc =
+          Acc.with_cost_metrics
+            (Cost_metrics.( + ) (Acc.cost_metrics acc) cost_metrics_of_body)
+            (Acc.with_free_names free_names_of_body acc)
+        in
+        acc, code_after_call)
+      ~body:apply ~is_exn_handler:false ~is_cold:false
+  in
+  match[@ocaml.warning "-fragile-match"] prim, args with
+  | Pperform, [[eff]] ->
+    let call_kind = Call_kind.perform ~eff in
+    close call_kind
+  | Prunstack, [[stack]; [f]; [arg]] ->
+    let call_kind = Call_kind.run_stack ~stack ~f ~arg in
+    close call_kind
+  | Presume, [[stack]; [f]; [arg]] ->
+    let call_kind = Call_kind.resume ~stack ~f ~arg in
+    close call_kind
+  | Preperform, [[eff]; [cont]; [last_fiber]] ->
+    let call_kind = Call_kind.reperform ~eff ~cont ~last_fiber in
+    close call_kind
+  | _ ->
+    Misc.fatal_errorf
+      "close_effect_primitive: Wrong primitive and/or number of arguments: %a \
+       (%d args)"
+      Printlambda.primitive prim (List.length args)
+
 let close_primitive acc env ~let_bound_ids_with_kinds named
     (prim : Lambda.primitive) ~args loc
     (exn_continuation : IR.exn_continuation option) ~current_region
@@ -837,6 +909,17 @@ let close_primitive acc env ~let_bound_ids_with_kinds named
         assert false
     in
     k acc [Named.create_simple (Simple.symbol sym)]
+  | (Pperform | Prunstack | Presume | Preperform), args ->
+    let exn_continuation =
+      match exn_continuation with
+      | None ->
+        Misc.fatal_errorf
+          "Effect primitive is missing exception continuation: %a"
+          IR.print_named named
+      | Some exn_continuation -> exn_continuation
+    in
+    close_effect_primitive acc env ~dbg exn_continuation prim ~args
+      ~let_bound_ids_with_kinds k
   | prim, args ->
     Lambda_to_flambda_primitives.convert_and_bind acc exn_continuation
       ~big_endian:(Env.big_endian env) ~register_const0 prim ~args dbg

middle_end/flambda2/from_lambda/closure_conversion_aux.ml

@@ -938,8 +938,7 @@ module Expr_with_acc = struct
             { function_call = Indirect_unknown_arity | Indirect_known_arity; _ }
           ->
           false
-        | Method _ -> false
-        | C_call _ -> false)
+        | Method _ | C_call _ | Effect _ -> false)
     in
     let acc =
       match Apply.callee apply with

middle_end/flambda2/from_lambda/lambda_to_flambda.ml

@@ -659,7 +659,8 @@ let primitive_can_raise (prim : Lambda.primitive) =
   | Punboxed_product_field _ | Pget_header _ ->
     false
   | Patomic_exchange | Patomic_cas | Patomic_fetch_add | Patomic_load _ -> false
-  | Prunstack | Pperform | Presume | Preperform | Pdls_get ->
+  | Prunstack | Pperform | Presume | Preperform -> true (* XXX! *)
+  | Pdls_get ->
     Misc.fatal_errorf "Primitive %a is not yet supported by Flambda 2"
       Printlambda.primitive prim
 

middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml

@@ -1506,7 +1506,8 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
        %a (%a)"
       Printlambda.primitive prim H.print_list_of_lists_of_simple_or_prim args
   | ( ( Pignore | Psequand | Psequor | Pbytes_of_string | Pbytes_to_string
-      | Parray_of_iarray | Parray_to_iarray ),
+      | Parray_of_iarray | Parray_to_iarray | Prunstack | Pperform | Presume
+      | Preperform ),
       _ ) ->
     Misc.fatal_errorf
       "[%a] should have been removed by [Lambda_to_flambda.transform_primitive]"
@@ -1515,7 +1516,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
     Misc.fatal_errorf
       "[%a] should have been handled by [Closure_conversion.close_primitive]"
       Printlambda.primitive prim
-  | (Prunstack | Pperform | Presume | Preperform | Pdls_get), _ ->
+  | Pdls_get, _ ->
     Misc.fatal_errorf "Primitive %a is not yet supported by Flambda 2"
       Printlambda.primitive prim
 

middle_end/flambda2/kinds/flambda_arity.mli

@@ -55,7 +55,7 @@ val create : 'uc Component_for_creation.t list -> 'uc t
 val create_singletons : Flambda_kind.With_subkind.t list -> [> ] t
 
 (** "No parameters".  (Not e.g. "one parameter of type void".) *)
-val nullary : [> `Unarized] t
+val nullary : [> ] t
 
 (** How many parameters, potentially of unboxed product layout, the given
     arity describes. *)

middle_end/flambda2/parser/flambda_to_fexpr.ml

@@ -1028,6 +1028,7 @@ and apply_expr env (app : Apply_expr.t) : Fexpr.expr =
       Function (Indirect alloc)
     | C_call { needs_caml_c_call; _ } -> C_call { alloc = needs_caml_c_call }
     | Method _ -> Misc.fatal_error "TODO: Method call kind"
+    | Effect _ -> Misc.fatal_error "TODO: Effect call kind"
   in
   let param_arity = Apply_expr.args_arity app in
   let return_arity = Apply_expr.return_arity app in
@@ -1051,9 +1052,9 @@ and apply_expr env (app : Apply_expr.t) : Fexpr.expr =
       let params_arity = Some (complex_arity param_arity) in
       let ret_arity = arity return_arity in
       Some { params_arity; ret_arity }
-    | Function { function_call = Indirect_unknown_arity; alloc_mode = _ }
-    | Method _ ->
+    | Function { function_call = Indirect_unknown_arity; alloc_mode = _ } ->
       None
+    | Method _ | Effect _ -> assert false
   in
   let inlined : Fexpr.inlined_attribute option =
     if Flambda2_terms.Inlined_attribute.is_default (Apply_expr.inlined app)

middle_end/flambda2/simplify/inlining/inlining_transforms.ml

@@ -95,10 +95,11 @@ let inline dacc ~apply ~unroll_to ~was_inline_always function_decl =
   let callee = Apply.callee apply in
   let region_inlined_into =
     match Apply.call_kind apply with
-    | Function { alloc_mode; _ } | Method { alloc_mode; _ } -> alloc_mode
-    | C_call _ ->
+    | Function { alloc_mode; _ } -> alloc_mode
+    | Method _ | C_call _ | Effect _ ->
       Misc.fatal_error
-        "Trying to call [Inlining_transforms.inline] on a C call."
+        "Trying to call [Inlining_transforms.inline] on something other than \
+         an OCaml function call."
   in
   let args = Apply.args apply in
   let apply_return_continuation = Apply.continuation apply in

middle_end/flambda2/simplify/simplify_apply_expr.ml

@@ -1034,14 +1034,14 @@ let simplify_apply_shared dacc apply =
   in
   dacc, callee_ty, apply, arg_types
 
-let rebuild_method_call apply ~use_id ~exn_cont_use_id uacc ~after_rebuild =
+let rebuild_non_ocaml_function_call apply ~use_id ~exn_cont_use_id uacc
+    ~after_rebuild =
   let apply =
     Simplify_common.update_exn_continuation_extra_args uacc ~exn_cont_use_id
       apply
   in
   let uacc, expr =
-    EB.rewrite_fixed_arity_apply uacc ~use_id:(Some use_id)
-      (Apply.return_arity apply) apply
+    EB.rewrite_fixed_arity_apply uacc ~use_id (Apply.return_arity apply) apply
   in
   after_rebuild expr uacc
 
@@ -1091,18 +1091,10 @@ let simplify_method_call dacc apply ~callee_ty ~kind:_ ~obj ~arg_types
     record_free_names_of_apply_as_used dacc ~use_id:(Some use_id)
       ~exn_cont_use_id apply
   in
-  down_to_up dacc ~rebuild:(rebuild_method_call apply ~use_id ~exn_cont_use_id)
-
-let rebuild_c_call apply ~use_id ~exn_cont_use_id ~return_arity uacc
-    ~after_rebuild =
-  let apply =
-    Simplify_common.update_exn_continuation_extra_args uacc ~exn_cont_use_id
-      apply
-  in
-  let uacc, expr =
-    EB.rewrite_fixed_arity_apply uacc ~use_id return_arity apply
-  in
-  after_rebuild expr uacc
+  down_to_up dacc
+    ~rebuild:
+      (rebuild_non_ocaml_function_call apply ~use_id:(Some use_id)
+         ~exn_cont_use_id)
 
 let simplify_c_call ~simplify_expr dacc apply ~callee_ty ~arg_types ~down_to_up
     =
@@ -1170,14 +1162,58 @@ let simplify_c_call ~simplify_expr dacc apply ~callee_ty ~arg_types ~down_to_up
       record_free_names_of_apply_as_used dacc ~use_id ~exn_cont_use_id apply
     in
     down_to_up dacc
-      ~rebuild:(rebuild_c_call apply ~use_id ~exn_cont_use_id ~return_arity)
+      ~rebuild:(rebuild_non_ocaml_function_call apply ~use_id ~exn_cont_use_id)
   | Invalid ->
     let rebuild uacc ~after_rebuild =
       let uacc = UA.notify_removed ~operation:Removed_operations.call uacc in
       EB.rebuild_invalid uacc (Closure_type_was_invalid apply) ~after_rebuild
     in
     down_to_up dacc ~rebuild
 
+let simplify_effect_op dacc apply (op : Call_kind.Effect.t) ~down_to_up =
+  fail_if_probe apply;
+  let denv = DA.denv dacc in
+  (match op with
+  | Perform { eff } -> DE.check_simple_is_bound denv eff
+  | Reperform { eff; cont; last_fiber } ->
+    DE.check_simple_is_bound denv eff;
+    DE.check_simple_is_bound denv cont;
+    DE.check_simple_is_bound denv last_fiber
+  | Run_stack { stack; f; arg } ->
+    DE.check_simple_is_bound denv stack;
+    DE.check_simple_is_bound denv f;
+    DE.check_simple_is_bound denv arg
+  | Resume { stack; f; arg } ->
+    DE.check_simple_is_bound denv stack;
+    DE.check_simple_is_bound denv f;
+    DE.check_simple_is_bound denv arg);
+  let dacc, use_id =
+    match Apply.continuation apply with
+    | Never_returns -> dacc, None
+    | Return continuation ->
+      let dacc, use_id =
+        DA.record_continuation_use dacc continuation
+          (Non_inlinable { escaping = true })
+          ~env_at_use:denv
+          ~arg_types:(T.unknown_types_from_arity (Apply.return_arity apply))
+      in
+      dacc, Some use_id
+  in
+  let dacc, exn_cont_use_id =
+    DA.record_continuation_use dacc
+      (Exn_continuation.exn_handler (Apply.exn_continuation apply))
+      (Non_inlinable { escaping = true })
+      ~env_at_use:(DA.denv dacc)
+      ~arg_types:
+        (T.unknown_types_from_arity
+           (Exn_continuation.arity (Apply.exn_continuation apply)))
+  in
+  let dacc =
+    record_free_names_of_apply_as_used dacc ~use_id ~exn_cont_use_id apply
+  in
+  down_to_up dacc
+    ~rebuild:(rebuild_non_ocaml_function_call apply ~use_id ~exn_cont_use_id)
+
 let simplify_apply ~simplify_expr dacc apply ~down_to_up =
   let dacc, callee_ty, apply, arg_types = simplify_apply_shared dacc apply in
   match Apply.call_kind apply with
@@ -1207,3 +1243,4 @@ let simplify_apply ~simplify_expr dacc apply ~down_to_up =
         Misc.fatal_errorf "No callee provided for C call:@ %a" Apply.print apply
     in
     simplify_c_call ~simplify_expr dacc apply ~callee_ty ~arg_types ~down_to_up
+  | Effect op -> simplify_effect_op dacc apply op ~down_to_up