Restore #1455: Communicate layouts to middle end

backend/cmm_helpers.ml

@@ -1930,7 +1930,8 @@ let box_sized size mode dbg exp =
 
 (* Simplification of some primitives into C calls *)
 
-let default_prim name = Primitive.simple ~name ~arity:0 (*ignored*) ~alloc:true
+let default_prim name =
+  Primitive.simple_on_values ~name ~arity:0 (*ignored*) ~alloc:true
 
 let int64_native_prim name arity ~alloc =
   let u64 = Primitive.(Prim_global, Unboxed_integer Pint64) in

backend/cmmgen.ml

@@ -612,7 +612,7 @@ let rec transl env e =
           transl_make_array dbg env kind alloc_heap args
       | (Pduparray _, [arg]) ->
           let prim_obj_dup =
-            Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true
+            Primitive.simple_on_values ~name:"caml_obj_dup" ~arity:1 ~alloc:true
           in
           transl_ccall env prim_obj_dup [arg] dbg
       | (Pmakearray _, []) ->
@@ -895,9 +895,13 @@ and transl_make_array dbg env kind mode args =
 
 and transl_ccall env prim args dbg =
   let transl_arg native_repr arg =
+    (* CR layouts v2: This match to be extended with
+         | Same_as_ocaml_repr Float64 -> (XFloat, transl env arg)
+       in the PR that adds Float64 *)
     match native_repr with
-    | Same_as_ocaml_repr ->
+    | Same_as_ocaml_repr Value ->
         (XInt, transl env arg)
+    | Same_as_ocaml_repr Void -> assert false
     | Unboxed_float ->
         (XFloat, transl_unbox_float dbg env arg)
     | Unboxed_integer bi ->
@@ -924,8 +928,12 @@ and transl_ccall env prim args dbg =
         (ty1 :: tys, arg' :: args')
   in
   let typ_res, wrap_result =
+    (* CR layouts v2: This match to be extended with
+         | Same_as_ocaml_repr Float64 -> (typ_float, fun x -> x)
+       in the PR that adds Float64 *)
     match prim.prim_native_repr_res with
-    | _, Same_as_ocaml_repr -> (typ_val, fun x -> x)
+    | _, Same_as_ocaml_repr Value -> (typ_val, fun x -> x)
+    | _, Same_as_ocaml_repr Void -> assert false
     (* TODO: Allow Alloc_local on suitably typed C stubs *)
     | _, Unboxed_float -> (typ_float, box_float dbg alloc_heap)
     | _, Unboxed_integer Pint64 when size_int = 4 ->

middle_end/convert_primitives.ml

@@ -152,8 +152,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]
-      ~native_repr_res:(P.Prim_global, P.Same_as_ocaml_repr))
+      ~native_repr_args:[P.Prim_global, P.Same_as_ocaml_repr Layouts.Sort.Value]
+      ~native_repr_res:(P.Prim_global, P.Same_as_ocaml_repr Layouts.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 ~name:"caml_check_value_is_closure"
+      Primitive.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 ~name:"caml_check_field_access"
+      Primitive.simple_on_values ~name:"caml_check_field_access"
         ~arity:3 ~alloc:false
     in
     let str =

middle_end/flambda2/from_lambda/closure_conversion.ml

@@ -439,7 +439,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds
   in
   let box_return_value =
     match prim_native_repr_res with
-    | _, Same_as_ocaml_repr -> None
+    | _, Same_as_ocaml_repr _ -> None
     | _, Unboxed_float ->
       Some (P.Box_number (Naked_float, Alloc_mode.For_allocations.heap))
     | _, Unboxed_integer Pnativeint ->
@@ -463,8 +463,11 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds
   in
   let kind_of_primitive_native_repr
       ((_, repr) : Primitive.mode * Primitive.native_repr) =
+    (* CR layouts v2: This match will be extended with [| Same_as_ocaml_repr
+       Float64 -> K.naked_float] in the PR that adds Float64. *)
     match repr with
-    | Same_as_ocaml_repr -> K.value
+    | Same_as_ocaml_repr Value -> K.value
+    | Same_as_ocaml_repr Void -> assert false
     | Unboxed_float -> K.naked_float
     | Unboxed_integer Pnativeint -> K.naked_nativeint
     | Unboxed_integer Pint32 -> K.naked_int32
@@ -549,7 +552,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds
            (arg_repr : Primitive.mode * Primitive.native_repr) ->
         let unbox_arg : P.unary_primitive option =
           match arg_repr with
-          | _, Same_as_ocaml_repr -> None
+          | _, Same_as_ocaml_repr _ -> None
           | _, Unboxed_float -> Some (P.Unbox_number Naked_float)
           | _, Unboxed_integer Pnativeint ->
             Some (P.Unbox_number Naked_nativeint)

middle_end/flambda2/from_lambda/dissect_letrec.ml

@@ -172,7 +172,7 @@ let lsequence (lam1, lam2) =
   [@@ocaml.warning "-fragile-match"]
 
 let caml_update_dummy_prim =
-  Primitive.simple ~name:"caml_update_dummy" ~arity:2 ~alloc:true
+  Primitive.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"
           | Boxed_float -> "caml_alloc_dummy_float"
         in
-        let desc = Primitive.simple ~name:fn ~arity:1 ~alloc:true in
+        let desc = Primitive.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

@@ -678,7 +678,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 ~name ~arity ~alloc:true in
+        let desc = Primitive.simple_on_values ~name ~arity ~alloc:true in
         Primitive (L.Pccall desc, args, loc)
       else
         Misc.fatal_errorf
@@ -695,7 +695,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 ~name ~arity ~alloc:true in
+        let desc = Primitive.simple_on_values ~name ~arity ~alloc:true in
         Primitive (L.Pccall desc, args, loc)
       else
         Misc.fatal_errorf

ocaml/.depend

@@ -434,7 +434,6 @@ parsing/jane_syntax.cmo : \
     parsing/parsetree.cmi \
     parsing/longident.cmi \
     parsing/location.cmi \
-    utils/language_extension.cmi \
     parsing/jane_syntax_parsing.cmi \
     parsing/asttypes.cmi \
     parsing/ast_helper.cmi \
@@ -443,7 +442,6 @@ parsing/jane_syntax.cmx : \
     parsing/parsetree.cmi \
     parsing/longident.cmx \
     parsing/location.cmx \
-    utils/language_extension.cmx \
     parsing/jane_syntax_parsing.cmx \
     parsing/asttypes.cmi \
     parsing/ast_helper.cmx \
@@ -1236,19 +1234,22 @@ typing/primitive.cmo : \
     typing/outcometree.cmi \
     utils/misc.cmi \
     parsing/location.cmi \
+    typing/layouts.cmi \
     parsing/attr_helper.cmi \
     typing/primitive.cmi
 typing/primitive.cmx : \
     parsing/parsetree.cmi \
     typing/outcometree.cmi \
     utils/misc.cmx \
     parsing/location.cmx \
+    typing/layouts.cmx \
     parsing/attr_helper.cmx \
     typing/primitive.cmi
 typing/primitive.cmi : \
     parsing/parsetree.cmi \
     typing/outcometree.cmi \
-    parsing/location.cmi
+    parsing/location.cmi \
+    typing/layouts.cmi
 typing/printpat.cmo : \
     typing/types.cmi \
     typing/typedtree.cmi \
@@ -1980,6 +1981,7 @@ typing/typeopt.cmi : \
     typing/typedtree.cmi \
     typing/path.cmi \
     parsing/location.cmi \
+    typing/layouts.cmi \
     lambda/lambda.cmi \
     typing/env.cmi
 typing/types.cmo : \
@@ -3710,6 +3712,7 @@ lambda/lambda.cmo : \
     utils/misc.cmi \
     parsing/longident.cmi \
     parsing/location.cmi \
+    typing/layouts.cmi \
     typing/ident.cmi \
     typing/env.cmi \
     lambda/debuginfo.cmi \
@@ -3725,6 +3728,7 @@ lambda/lambda.cmx : \
     utils/misc.cmx \
     parsing/longident.cmx \
     parsing/location.cmx \
+    typing/layouts.cmx \
     typing/ident.cmx \
     typing/env.cmx \
     lambda/debuginfo.cmx \
@@ -3739,6 +3743,7 @@ lambda/lambda.cmi : \
     typing/primitive.cmi \
     typing/path.cmi \
     parsing/location.cmi \
+    typing/layouts.cmi \
     typing/ident.cmi \
     typing/env.cmi \
     lambda/debuginfo.cmi \
@@ -3793,6 +3798,7 @@ lambda/matching.cmx : \
 lambda/matching.cmi : \
     typing/typedtree.cmi \
     parsing/location.cmi \
+    typing/layouts.cmi \
     lambda/lambda.cmi \
     typing/ident.cmi \
     lambda/debuginfo.cmi
@@ -3881,6 +3887,7 @@ lambda/transl_array_comprehension.cmo : \
     typing/predef.cmi \
     utils/misc.cmi \
     lambda/matching.cmi \
+    typing/layouts.cmi \
     lambda/lambda.cmi \
     typing/ident.cmi \
     typing/env.cmi \
@@ -3894,6 +3901,7 @@ lambda/transl_array_comprehension.cmx : \
     typing/predef.cmx \
     utils/misc.cmx \
     lambda/matching.cmx \
+    typing/layouts.cmx \
     lambda/lambda.cmx \
     typing/ident.cmx \
     typing/env.cmx \
@@ -3902,6 +3910,7 @@ lambda/transl_array_comprehension.cmx : \
     lambda/transl_array_comprehension.cmi
 lambda/transl_array_comprehension.cmi : \
     typing/typedtree.cmi \
+    typing/layouts.cmi \
     lambda/lambda.cmi \
     lambda/debuginfo.cmi
 lambda/transl_comprehension_utils.cmo : \
@@ -3923,6 +3932,7 @@ lambda/transl_list_comprehension.cmo : \
     typing/typedtree.cmi \
     lambda/transl_comprehension_utils.cmi \
     lambda/matching.cmi \
+    typing/layouts.cmi \
     lambda/lambda.cmi \
     typing/ident.cmi \
     parsing/asttypes.cmi \
@@ -3932,12 +3942,14 @@ lambda/transl_list_comprehension.cmx : \
     typing/typedtree.cmx \
     lambda/transl_comprehension_utils.cmx \
     lambda/matching.cmx \
+    typing/layouts.cmx \
     lambda/lambda.cmx \
     typing/ident.cmx \
     parsing/asttypes.cmi \
     lambda/transl_list_comprehension.cmi
 lambda/transl_list_comprehension.cmi : \
     typing/typedtree.cmi \
+    typing/layouts.cmi \
     lambda/lambda.cmi \
     lambda/debuginfo.cmi
 lambda/translattribute.cmo : \
@@ -3980,6 +3992,7 @@ lambda/translclass.cmo : \
     typing/path.cmi \
     lambda/matching.cmi \
     parsing/location.cmi \
+    typing/layouts.cmi \
     lambda/lambda.cmi \
     typing/ident.cmi \
     typing/env.cmi \
@@ -3997,6 +4010,7 @@ lambda/translclass.cmx : \
     typing/path.cmx \
     lambda/matching.cmx \
     parsing/location.cmx \
+    typing/layouts.cmx \
     lambda/lambda.cmx \
     typing/ident.cmx \
     typing/env.cmx \
@@ -4083,6 +4097,7 @@ lambda/translcore.cmx : \
     parsing/asttypes.cmi \
     lambda/translcore.cmi
 lambda/translcore.cmi : \
+    typing/types.cmi \
     typing/typedtree.cmi \
     parsing/longident.cmi \
     parsing/location.cmi \
@@ -4204,6 +4219,7 @@ lambda/translprim.cmo : \
     utils/misc.cmi \
     lambda/matching.cmi \
     parsing/location.cmi \
+    typing/layouts.cmi \
     lambda/lambda.cmi \
     typing/ident.cmi \
     typing/env.cmi \
@@ -4224,6 +4240,7 @@ lambda/translprim.cmx : \
     utils/misc.cmx \
     lambda/matching.cmx \
     parsing/location.cmx \
+    typing/layouts.cmx \
     lambda/lambda.cmx \
     typing/ident.cmx \
     typing/env.cmx \

ocaml/asmcomp/cmm_helpers.ml

@@ -1579,7 +1579,7 @@ let box_sized size mode dbg exp =
 (* Simplification of some primitives into C calls *)
 
 let default_prim name =
-  Primitive.simple ~name ~arity:0(*ignored*) ~alloc:true
+  Primitive.simple_on_values ~name ~arity:0(*ignored*) ~alloc:true
 
 
 let int64_native_prim name arity ~alloc =

ocaml/asmcomp/cmmgen.ml

@@ -541,7 +541,7 @@ let rec transl env e =
           transl_make_array dbg env kind alloc_heap args
       | (Pduparray _, [arg]) ->
           let prim_obj_dup =
-            Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true
+            Primitive.simple_on_values ~name:"caml_obj_dup" ~arity:1 ~alloc:true
           in
           transl_ccall env prim_obj_dup [arg] dbg
       | (Pmakearray _, []) ->
@@ -826,9 +826,13 @@ and transl_make_array dbg env kind mode args =
 
 and transl_ccall env prim args dbg =
   let transl_arg native_repr arg =
+    (* CR layouts v2: This match to be extended with
+         | Same_as_ocaml_repr Float64 -> (XFloat, transl env arg)
+       in the PR that adds Float64 *)
     match native_repr with
-    | Same_as_ocaml_repr ->
+    | Same_as_ocaml_repr Value ->
         (XInt, transl env arg)
+    | Same_as_ocaml_repr Void -> assert false
     | Unboxed_float ->
         (XFloat, transl_unbox_float dbg env arg)
     | Unboxed_integer bi ->
@@ -856,7 +860,11 @@ and transl_ccall env prim args dbg =
   in
   let typ_res, wrap_result =
     match prim.prim_native_repr_res with
-    | _, Same_as_ocaml_repr -> (typ_val, fun x -> x)
+    (* CR layouts v2: This match to be extended with
+         | Same_as_ocaml_repr Float64 -> (typ_float, fun x -> x)
+       in the PR that adds Float64 *)
+    | _, Same_as_ocaml_repr Value -> (typ_val, fun x -> x)
+    | _, Same_as_ocaml_repr Void -> assert false
     (* TODO: Allow Alloc_local on suitably typed C stubs *)
     | _, Unboxed_float -> (typ_float, box_float dbg alloc_heap)
     | _, Unboxed_integer Pint64 when size_int = 4 ->

ocaml/bytecomp/bytegen.ml

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

ocaml/compilerlibs/Makefile.compilerlibs

@@ -80,9 +80,9 @@ PARSING_CMI = \
 
 TYPING = \
   typing/path.cmo \
+  typing/layouts.cmo \
   typing/primitive.cmo \
   typing/shape.cmo \
-  typing/layouts.cmo \
   typing/types.cmo \
   typing/btype.cmo \
   typing/oprint.cmo \

ocaml/dune

@@ -68,7 +68,7 @@
    asttypes parsetree
 
    ;; TYPING
-   ident path primitive shape layouts types btype oprint subst predef datarepr
+   ident path layouts primitive shape types btype oprint subst predef datarepr
    cmi_format persistent_env env errortrace
    typedtree printtyped ctype printtyp includeclass mtype envaux includecore
    tast_iterator tast_mapper signature_group cmt_format cms_format untypeast
@@ -263,8 +263,8 @@
     (parsetree.mli as compiler-libs/parsetree.mli)
     (ident.mli as compiler-libs/ident.mli)
     (path.mli as compiler-libs/path.mli)
-    (primitive.mli as compiler-libs/primitive.mli)
     (layouts.mli as compiler-libs/layouts.mli)
+    (primitive.mli as compiler-libs/primitive.mli)
     (types.mli as compiler-libs/types.mli)
     (btype.mli as compiler-libs/btype.mli)
     (binutils.mli as compiler-libs/binutils.mli)