Ban Prim_poly from Lambda

backend/cmm_builtins.ml

@@ -727,7 +727,7 @@ let transl_coeffects (ce : Primitive.coeffects) : Cmm.coeffects =
   match ce with No_coeffects -> No_coeffects | Has_coeffects -> Has_coeffects
 
 (* [cextcall] is called from [Cmmgen.transl_ccall] *)
-let cextcall (prim : Primitive.description) args dbg ret ty_args returns =
+let cextcall (prim : Lambda.external_call) args dbg ret ty_args returns =
   let name = Primitive.native_name prim in
   let default =
     Cop

backend/cmm_builtins.mli

@@ -31,7 +31,7 @@ val extcall :
     corresponds to [prim]. If [prim] is a C builtin supported on the target,
     returns [Cmm.operation] variant for [prim]'s intrinsics. *)
 val cextcall :
-  Primitive.description ->
+  Lambda.external_call ->
   expression list ->
   Debuginfo.t ->
   machtype ->

backend/cmm_helpers.ml

@@ -2060,7 +2060,7 @@ let box_sized size mode dbg exp =
 (* Simplification of some primitives into C calls *)
 
 let default_prim name =
-  Primitive.simple_on_values ~name ~arity:0 (*ignored*) ~alloc:true
+  Lambda.simple_on_values ~name ~arity:0 (*ignored*) ~alloc:true
 
 let simplif_primitive p : Clambda_primitives.primitive =
   match (p : Clambda_primitives.primitive) with

backend/cmmgen.ml

@@ -667,7 +667,7 @@ let rec transl env e =
           transl_make_array dbg env kind alloc_heap args
       | (Pduparray _, [arg]) ->
           let prim_obj_dup =
-            Primitive.simple_on_values ~name:"caml_obj_dup" ~arity:1 ~alloc:true
+            Lambda.simple_on_values ~name:"caml_obj_dup" ~arity:1 ~alloc:true
           in
           transl_ccall env prim_obj_dup [arg] dbg
       | (Pmakearray _, []) ->

middle_end/clambda_primitives.ml

@@ -55,7 +55,7 @@ type primitive =
   | Presume
   | Preperform
   (* External call *)
-  | Pccall of Primitive.description
+  | Pccall of Lambda.external_call
   (* Exceptions *)
   | Praise of raise_kind
   (* Boolean operations *)

middle_end/clambda_primitives.mli

@@ -55,7 +55,7 @@ type primitive =
   | Presume
   | Preperform
   (* External call *)
-  | Pccall of Primitive.description
+  | Pccall of Lambda.external_call
   (* Exceptions *)
   | Praise of raise_kind
   (* Boolean operations *)

middle_end/convert_primitives.ml

@@ -186,8 +186,8 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive =
       ~effects:Only_generative_effects
       ~coeffects:Has_coeffects
       ~native_name:"caml_obj_dup"
-      ~native_repr_args:[P.Prim_global, P.Same_as_ocaml_repr Jkind.Sort.Value]
-      ~native_repr_res:(P.Prim_global, P.Same_as_ocaml_repr Jkind.Sort.Value))
+      ~native_repr_args:[(), P.Same_as_ocaml_repr Jkind.Sort.Value]
+      ~native_repr_res:(Lambda.Prim_global, P.Same_as_ocaml_repr Jkind.Sort.Value))
   | Punbox_float -> Punbox_float
   | Pbox_float m -> Pbox_float m
   | Punbox_int bi -> Punbox_int bi

middle_end/flambda/flambda_to_clambda.ml

@@ -79,7 +79,7 @@ let check_closure t ulam named : Clambda.ulambda =
   if not !Clflags.clambda_checks then ulam
   else
     let desc =
-      Primitive.simple_on_values ~name:"caml_check_value_is_closure"
+      Lambda.simple_on_values ~name:"caml_check_value_is_closure"
         ~arity:2 ~alloc:false
     in
     let str = Format.asprintf "%a" Flambda.print_named named in
@@ -109,7 +109,7 @@ let check_field t ulam pos named_opt : Clambda.ulambda =
   if not !Clflags.clambda_checks then ulam
   else
     let desc =
-      Primitive.simple_on_values ~name:"caml_check_field_access"
+      Lambda.simple_on_values ~name:"caml_check_field_access"
         ~arity:3 ~alloc:false
     in
     let str =

middle_end/flambda2/from_lambda/closure_conversion.ml

@@ -424,7 +424,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds
         prim_native_repr_args;
         prim_native_repr_res
       } :
-       Primitive.description) as prim_desc) ~(args : Simple.t list list)
+       Lambda.external_call) as prim_desc) ~(args : Simple.t list list)
     exn_continuation dbg ~current_region
     (k : Acc.t -> Named.t list -> Expr_with_acc.t) : Expr_with_acc.t =
   let args =
@@ -493,8 +493,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds
       Apply_cont_expr.continuation apply_cont, false
     | _ -> Continuation.create (), true
   in
-  let kind_of_primitive_native_repr
-      ((_, repr) : Primitive.mode * Primitive.native_repr) =
+  let kind_of_primitive_native_repr ((_, repr) : _ * Primitive.native_repr) =
     match repr with
     | Same_as_ocaml_repr sort ->
       K.With_subkind.(
@@ -592,7 +591,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds
   let call : Acc.t -> Expr_with_acc.t =
     List.fold_left2
       (fun (call : Simple.t list -> Acc.t -> Expr_with_acc.t) arg
-           (arg_repr : Primitive.mode * Primitive.native_repr) ->
+           (arg_repr : _ * Primitive.native_repr) ->
         let unbox_arg : P.unary_primitive option =
           match arg_repr with
           | _, Same_as_ocaml_repr _ -> None

middle_end/flambda2/from_lambda/dissect_letrec.ml

@@ -171,7 +171,7 @@ let lsequence (lam1, lam2) =
   [@@ocaml.warning "-fragile-match"]
 
 let caml_update_dummy_prim =
-  Primitive.simple_on_values ~name:"caml_update_dummy" ~arity:2 ~alloc:true
+  simple_on_values ~name:"caml_update_dummy" ~arity:2 ~alloc:true
 
 let update_dummy var expr =
   Lprim (Pccall caml_update_dummy_prim, [Lvar var; expr], Loc_unknown)
@@ -570,7 +570,7 @@ let dissect_letrec ~bindings ~body ~free_vars_kind =
           | Normal _tag -> "caml_alloc_dummy"
           | Flat_float_record -> "caml_alloc_dummy_float"
         in
-        let desc = Primitive.simple_on_values ~name:fn ~arity:1 ~alloc:true in
+        let desc = simple_on_values ~name:fn ~arity:1 ~alloc:true in
         let size : lambda = Lconst (Const_base (Const_int size)) in
         id, Lprim (Pccall desc, [size], Loc_unknown))
       letrec.blocks

middle_end/flambda2/from_lambda/lambda_to_flambda.ml

@@ -298,7 +298,7 @@ let transform_primitive env (prim : L.primitive) args loc =
       then
         let arity = 1 + num_dimensions in
         let name = "caml_ba_get_" ^ string_of_int num_dimensions in
-        let desc = Primitive.simple_on_values ~name ~arity ~alloc:true in
+        let desc = L.simple_on_values ~name ~arity ~alloc:true in
         Primitive (L.Pccall desc, args, loc)
       else
         Misc.fatal_errorf
@@ -315,7 +315,7 @@ let transform_primitive env (prim : L.primitive) args loc =
       then
         let arity = 2 + num_dimensions in
         let name = "caml_ba_set_" ^ string_of_int num_dimensions in
-        let desc = Primitive.simple_on_values ~name ~arity ~alloc:true in
+        let desc = L.simple_on_values ~name ~arity ~alloc:true in
         Primitive (L.Pccall desc, args, loc)
       else
         Misc.fatal_errorf

ocaml/asmcomp/cmm_helpers.ml

@@ -1570,7 +1570,7 @@ let box_sized size mode dbg exp =
 (* Simplification of some primitives into C calls *)
 
 let default_prim name =
-  Primitive.simple_on_values ~name ~arity:0(*ignored*) ~alloc:true
+  Lambda.simple_on_values ~name ~arity:0(*ignored*) ~alloc:true
 
 let simplif_primitive p : Clambda_primitives.primitive =
   match (p : Clambda_primitives.primitive) with

ocaml/asmcomp/cmmgen.ml

@@ -582,7 +582,7 @@ let rec transl env e =
           transl_make_array dbg env kind alloc_heap args
       | (Pduparray _, [arg]) ->
           let prim_obj_dup =
-            Primitive.simple_on_values ~name:"caml_obj_dup" ~arity:1 ~alloc:true
+            simple_on_values ~name:"caml_obj_dup" ~arity:1 ~alloc:true
           in
           transl_ccall env prim_obj_dup [arg] dbg
       | (Pmakearray _, []) ->

ocaml/bytecomp/bytegen.ml

@@ -867,7 +867,7 @@ let rec comp_expr stack_info env exp sz cont =
         (Lprim (Pmakearray (kind, mutability, m), args, loc)) sz cont
   | Lprim (Pduparray _, [arg], loc) ->
       let prim_obj_dup =
-        Primitive.simple_on_values ~name:"caml_obj_dup" ~arity:1 ~alloc:true
+        Lambda.simple_on_values ~name:"caml_obj_dup" ~arity:1 ~alloc:true
       in
       comp_expr stack_info env (Lprim (Pccall prim_obj_dup, [arg], loc)) sz cont
   | Lprim (Pduparray _, _, _) ->

ocaml/lambda/lambda.ml

@@ -43,6 +43,10 @@ type field_read_semantics =
   | Reads_agree
   | Reads_vary
 
+type prim_mode =
+  | Prim_global
+  | Prim_local
+
 include (struct
 
   type locality_mode =
@@ -163,7 +167,7 @@ type primitive =
   | Presume
   | Preperform
   (* External call *)
-  | Pccall of Primitive.description
+  | Pccall of external_call
   (* Exceptions *)
   | Praise of raise_kind
   (* Boolean operations *)
@@ -351,6 +355,35 @@ and raise_kind =
   | Raise_reraise
   | Raise_notrace
 
+and external_call = (unit, prim_mode) Primitive.description_gen
+
+let external_call (prim_desc : Primitive.description) ~(ret_mode : alloc_mode) =
+  let native_repr_args =
+    List.map (fun (_, repr) -> (), repr) prim_desc.prim_native_repr_args
+  in
+  let native_repr_res =
+    match prim_desc.prim_native_repr_res with
+    | Prim_local, native_repr -> Prim_local, native_repr
+    | Prim_global, native_repr -> Prim_global, native_repr
+    | Prim_poly, native_repr ->
+      (* See comment in the .mli *)
+      match ret_mode with
+      | Alloc_heap -> Prim_global, native_repr
+      | Alloc_local -> Prim_local, native_repr
+  in
+  Primitive.make ~name:prim_desc.prim_name
+    ~alloc:prim_desc.prim_alloc
+    ~c_builtin:prim_desc.prim_c_builtin
+    ~effects:prim_desc.prim_effects
+    ~coeffects:prim_desc.prim_coeffects
+    ~native_name:prim_desc.prim_native_name
+    ~native_repr_args
+    ~native_repr_res
+
+let simple_on_values ~name ~arity ~alloc =
+  Primitive.simple_on_values_gen ~name ~arity ~alloc
+    ~arg_global:() ~ret_global:Prim_global
+
 let vec128_name = function
   | Unknown128 -> "unknown128"
   | Int8x16 -> "int8x16"
@@ -1440,12 +1473,12 @@ let mod_field ?(read_semantics=Reads_agree) pos =
 let mod_setfield pos =
   Psetfield (pos, Pointer, Root_initialization)
 
-let alloc_mode_of_primitive_description (p : Primitive.description) =
+let alloc_mode_of_primitive_description (p : external_call) =
   if not Config.stack_allocation then
     if p.prim_alloc then Some alloc_heap else None
   else
     match p.prim_native_repr_res with
-    | (Prim_local | Prim_poly), _ ->
+    | Prim_local, _ ->
       (* For primitives that might allocate locally, [p.prim_alloc] just says
          whether [caml_c_call] is required, without telling us anything
          about local allocation.  (However if [p.prim_alloc = false] we

ocaml/lambda/lambda.mli

@@ -37,6 +37,12 @@ type immediate_or_pointer =
   | Immediate
   | Pointer
 
+(* like [Primitive.mode], but without [Prim_poly]; see comments on declaration
+   of [external_call] *)
+type prim_mode =
+  | Prim_global
+  | Prim_local
+
 type locality_mode = private
   | Alloc_heap
   | Alloc_local
@@ -121,7 +127,7 @@ type primitive =
   | Presume
   | Preperform
   (* External call *)
-  | Pccall of Primitive.description
+  | Pccall of external_call
   (* Exceptions *)
   | Praise of raise_kind
   (* Boolean operations *)
@@ -328,6 +334,20 @@ and raise_kind =
   | Raise_reraise
   | Raise_notrace
 
+and external_call = (unit, prim_mode) Primitive.description_gen
+  (** We cannot have [Prim_poly] in Lambda code. Changing the parameter
+      on [Primitive.description_gen] from [Primitive.mode] to [prim_mode]
+      ensures this is the case. (We also have no need for argument modes
+      in Lambda, thus the [unit].) Avoiding [Prim_poly] ensures that we can
+      precisely identify whether or not the frontend decided that this
+      particular primitive application needed an enclosing region or not.
+      Also see [alloc_mode_of_primitive_description]. *)
+
+val external_call : Primitive.description -> ret_mode:alloc_mode
+  -> external_call
+
+val simple_on_values : name:string -> arity:int -> alloc:bool -> external_call
+
 val vec128_name: vec128_type -> string
 
 val join_boxed_vector_layout: boxed_vector -> boxed_vector -> layout
@@ -752,8 +772,7 @@ val primitive_may_allocate : primitive -> alloc_mode option
       revised.
   *)
 
-val alloc_mode_of_primitive_description :
-  Primitive.description -> alloc_mode option
+val alloc_mode_of_primitive_description : external_call -> alloc_mode option
   (** Like [primitive_may_allocate], for [external] calls. *)
 
 (***********************)

ocaml/lambda/matching.ml

@@ -1907,7 +1907,7 @@ let get_pat_args_lazy p rem =
 *)
 
 let prim_obj_tag =
-  Primitive.simple_on_values ~name:"caml_obj_tag" ~arity:1 ~alloc:false
+  Lambda.simple_on_values ~name:"caml_obj_tag" ~arity:1 ~alloc:false
 
 let get_mod_field modname field =
   lazy
@@ -2247,11 +2247,11 @@ let divide_array ~scopes kind ctx pm =
 let strings_test_threshold = 8
 
 let prim_string_notequal =
-  Pccall (Primitive.simple_on_values ~name:"caml_string_notequal" ~arity:2
+  Pccall (Lambda.simple_on_values ~name:"caml_string_notequal" ~arity:2
             ~alloc:false)
 
 let prim_string_compare =
-  Pccall (Primitive.simple_on_values ~name:"caml_string_compare" ~arity:2
+  Pccall (Lambda.simple_on_values ~name:"caml_string_compare" ~arity:2
             ~alloc:false)
 
 let bind_sw arg layout k =

ocaml/lambda/transl_comprehension_utils.ml

@@ -114,7 +114,7 @@ module Lambda_utils = struct
     (** The Lambda primitive for calling a simple C primitive *)
     (* CR layouts v4: To change when non-values are allowed in arrays. *)
     let c_prim name arity =
-      Pccall (Primitive.simple_on_values ~name ~arity ~alloc:true)
+      Pccall (Lambda.simple_on_values ~name ~arity ~alloc:true)
 
     (** Create a function that produces the Lambda representation for a
         one-argument C primitive when provided with a Lambda argument *)

ocaml/lambda/translcore.ml

@@ -98,7 +98,7 @@ let declare_probe_handlers lam =
 
 let prim_fresh_oo_id =
   Pccall
-    (Primitive.simple_on_values ~name:"caml_fresh_oo_id" ~arity:1 ~alloc:false)
+    (Lambda.simple_on_values ~name:"caml_fresh_oo_id" ~arity:1 ~alloc:false)
 
 let transl_extension_constructor ~scopes env path ext =
   let path =
@@ -374,9 +374,10 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
         if extra_args = [] then transl_apply_position pos
         else Rc_normal
       in
+      let mode = transl_locality_mode ap_mode in
       let lam =
         Translprim.transl_primitive_application
-          (of_location ~scopes e.exp_loc) p e.exp_env prim_type pmode
+          (of_location ~scopes e.exp_loc) p e.exp_env prim_type pmode mode
           path prim_exp args (List.map fst arg_exps) position
       in
       if extra_args = [] then lam
@@ -385,7 +386,6 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
         let inlined = Translattribute.get_inlined_attribute funct in
         let specialised = Translattribute.get_specialised_attribute funct in
         let position = transl_apply_position pos in
-        let mode = transl_locality_mode ap_mode in
         let result_layout = layout_exp sort e in
         event_after ~scopes e
           (transl_apply ~scopes ~tailcall ~inlined ~specialised ~position ~mode

ocaml/lambda/translmod.ml

@@ -268,7 +268,7 @@ let record_primitive = function
 let preallocate_letrec ~bindings ~body =
   assert (Clflags.is_flambda2 ());
   let caml_update_dummy_prim =
-    Primitive.simple_on_values ~name:"caml_update_dummy" ~arity:2 ~alloc:true
+    simple_on_values ~name:"caml_update_dummy" ~arity:2 ~alloc:true
   in
   let update_dummy var expr =
     Lprim (Pccall caml_update_dummy_prim, [Lvar var; expr], Loc_unknown)
@@ -282,8 +282,7 @@ let preallocate_letrec ~bindings ~body =
   List.fold_left
     (fun body (id, _def, size) ->
        let desc =
-         Primitive.simple_on_values ~name:"caml_alloc_dummy" ~arity:1
-           ~alloc:true
+         simple_on_values ~name:"caml_alloc_dummy" ~arity:1 ~alloc:true
        in
        let size : lambda = Lconst (Const_base (Const_int size)) in
        Llet (Strict, Lambda.layout_block, id,

ocaml/lambda/translobj.ml

@@ -84,7 +84,7 @@ let int n = Lconst (Const_base (Const_int n))
 
 (* CR layouts v5: To change when we have arrays of other sorts *)
 let prim_makearray =
-  Primitive.simple_on_values ~name:"caml_make_vect" ~arity:2 ~alloc:true
+  Lambda.simple_on_values ~name:"caml_make_vect" ~arity:2 ~alloc:true
 
 (* Also use it for required globals *)
 let transl_label_init_general f =