Skip to content

Commit

Permalink
Communicate frontend layouts to lambda (#1455)
Browse files Browse the repository at this point in the history
  • Loading branch information
ccasin authored Jun 15, 2023
1 parent 134496e commit a794501
Show file tree
Hide file tree
Showing 59 changed files with 1,161 additions and 746 deletions.
3 changes: 2 additions & 1 deletion backend/cmm_helpers.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
14 changes: 11 additions & 3 deletions backend/cmmgen.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 _, []) ->
Expand Down Expand Up @@ -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 ->
Expand All @@ -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 ->
Expand Down
4 changes: 2 additions & 2 deletions middle_end/convert_primitives.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
4 changes: 2 additions & 2 deletions middle_end/flambda/flambda_to_clambda.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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 =
Expand Down
9 changes: 6 additions & 3 deletions middle_end/flambda2/from_lambda/closure_conversion.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 ->
Expand All @@ -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
Expand Down Expand Up @@ -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)
Expand Down
4 changes: 2 additions & 2 deletions middle_end/flambda2/from_lambda/dissect_letrec.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand Down
4 changes: 2 additions & 2 deletions middle_end/flambda2/from_lambda/lambda_to_flambda.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down
23 changes: 20 additions & 3 deletions ocaml/.depend
Original file line number Diff line number Diff line change
Expand Up @@ -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 \
Expand All @@ -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 \
Expand Down Expand Up @@ -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 \
Expand Down Expand Up @@ -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 : \
Expand Down Expand Up @@ -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 \
Expand All @@ -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 \
Expand All @@ -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 \
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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 \
Expand All @@ -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 \
Expand All @@ -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 : \
Expand All @@ -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 \
Expand All @@ -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 : \
Expand Down Expand Up @@ -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 \
Expand All @@ -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 \
Expand Down Expand Up @@ -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 \
Expand Down Expand Up @@ -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 \
Expand All @@ -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 \
Expand Down
2 changes: 1 addition & 1 deletion ocaml/asmcomp/cmm_helpers.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand Down
14 changes: 11 additions & 3 deletions ocaml/asmcomp/cmmgen.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 _, []) ->
Expand Down Expand Up @@ -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 ->
Expand Down Expand Up @@ -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 ->
Expand Down
Binary file modified ocaml/boot/ocamlc
Binary file not shown.
Binary file modified ocaml/boot/ocamllex
Binary file not shown.
2 changes: 1 addition & 1 deletion ocaml/bytecomp/bytegen.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 _, _, _) ->
Expand Down
2 changes: 1 addition & 1 deletion ocaml/compilerlibs/Makefile.compilerlibs
Original file line number Diff line number Diff line change
Expand Up @@ -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 \
Expand Down
4 changes: 2 additions & 2 deletions ocaml/dune
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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)
Expand Down
Loading

0 comments on commit a794501

Please sign in to comment.