diff --git a/backend/amd64/proc.ml b/backend/amd64/proc.ml index c58a01f0563..e4cc9d37e64 100644 --- a/backend/amd64/proc.ml +++ b/backend/amd64/proc.ml @@ -559,6 +559,7 @@ let operation_supported = function | Craise _ | Ccheckbound | Cprobe _ | Cprobe_is_enabled _ | Copaque | Cbeginregion | Cendregion + | Ctuple_field _ -> true let trap_size_in_bytes = 16 diff --git a/backend/cmm.ml b/backend/cmm.ml index 7812285de45..2d7c59442c8 100644 --- a/backend/cmm.ml +++ b/backend/cmm.ml @@ -217,6 +217,7 @@ and operation = | Cprobe_is_enabled of { name: string } | Copaque | Cbeginregion | Cendregion + | Ctuple_field of int * machtype array type kind_for_unboxing = | Any diff --git a/backend/cmm.mli b/backend/cmm.mli index 244f50b7b86..a86ac96663a 100644 --- a/backend/cmm.mli +++ b/backend/cmm.mli @@ -219,6 +219,7 @@ and operation = | Cprobe_is_enabled of { name: string } | Copaque (* Sys.opaque_identity *) | Cbeginregion | Cendregion + | Ctuple_field of int * machtype array (* This is information used exclusively during construction of cmm terms by cmmgen, and thus irrelevant for selectgen and flambda2. *) diff --git a/backend/cmm_helpers.ml b/backend/cmm_helpers.ml index ff688cfb23d..f3edcc3f497 100644 --- a/backend/cmm_helpers.ml +++ b/backend/cmm_helpers.ml @@ -1060,7 +1060,7 @@ module Extended_machtype = struct let change_tagged_int_to_val t = Array.map Extended_machtype_component.change_tagged_int_to_val t - let of_layout (layout : Lambda.layout) = + let rec of_layout (layout : Lambda.layout) = match layout with | Ptop -> Misc.fatal_error "No Extended_machtype for layout [Ptop]" | Pbottom -> @@ -1071,6 +1071,7 @@ module Extended_machtype = struct typ_any_int | Pvalue Pintval -> typ_tagged_int | Pvalue _ -> typ_val + | Punboxed_product fields -> Array.concat @@ List.map of_layout fields end let machtype_of_layout layout = @@ -4044,8 +4045,8 @@ let direct_call ~dbg ty pos f_code_sym args = Cop (Capply (ty, pos), f_code_sym :: args, dbg) let indirect_call ~dbg ty pos alloc_mode f args_type args = - match args with - | [arg] -> + match args_type with + | [_] -> (* Use a variable to avoid duplicating the cmm code of the closure [f]. *) let v = Backend_var.create_local "*closure*" in let v' = Backend_var.With_provenance.create v in @@ -4053,10 +4054,10 @@ let indirect_call ~dbg ty pos alloc_mode f args_type args = ~body: (Cop ( Capply (Extended_machtype.to_machtype ty, pos), - [load ~dbg Word_int Asttypes.Mutable ~addr:(Cvar v); arg; Cvar v], + (load ~dbg Word_int Asttypes.Mutable ~addr:(Cvar v) :: args) + @ [Cvar v], dbg )) - | args -> - call_caml_apply ty args_type Asttypes.Mutable f args pos alloc_mode dbg + | _ -> call_caml_apply ty args_type Asttypes.Mutable f args pos alloc_mode dbg let indirect_full_call ~dbg ty pos alloc_mode f args_type = function (* the single-argument case is already optimized by indirect_call *) @@ -4183,5 +4184,5 @@ let kind_of_layout (layout : Lambda.layout) = | Pvalue Pfloatval -> Boxed_float | Pvalue (Pboxedintval bi) -> Boxed_integer bi | Pvalue (Pgenval | Pintval | Pvariant _ | Parrayval _) - | Ptop | Pbottom | Punboxed_float | Punboxed_int _ -> + | Ptop | Pbottom | Punboxed_float | Punboxed_int _ | Punboxed_product _ -> Any diff --git a/backend/cmmgen.ml b/backend/cmmgen.ml index 5ff1b2f00d1..e6c460e4aaf 100644 --- a/backend/cmmgen.ml +++ b/backend/cmmgen.ml @@ -150,6 +150,7 @@ let get_field env layout ptr n dbg = | Pvalue Pintval | Punboxed_int _ -> Word_int | Pvalue _ -> Word_val | Punboxed_float -> Double + | Punboxed_product _ -> Misc.fatal_error "TBD" | Ptop -> Misc.fatal_errorf "get_field with Ptop: %a" Debuginfo.print_compact dbg | Pbottom -> @@ -435,6 +436,36 @@ let rec is_unboxed_number_cmm = function (is_unboxed_number_cmm body) (List.map (fun (_, _, e, _) -> is_unboxed_number_cmm e) handlers) +type layout_atom = + | LValue + | Lunboxed_float + | Lunboxed_int of Lambda.boxed_integer + +let rec take_n n l = + if n <= 0 then [] + else + match l with + | [] -> assert false + | h :: t -> h :: (take_n (n-1) t) + +let rec flatten_layout (layout : Lambda.layout) = + match layout with + | Ptop -> assert false + | Pbottom -> [] + | Pvalue _ -> [LValue] + | Punboxed_float -> [Lunboxed_float] + | Punboxed_int b -> [Lunboxed_int b] + | Punboxed_product l -> + List.flatten (List.map flatten_layout l) + +let layout_machtype (atom : layout_atom) = + match atom with + | LValue -> typ_val + | Lunboxed_float -> typ_float + | Lunboxed_int _ -> + (* Only 64-bit architectures, so this is always [typ_int] *) + typ_int + (* Translate an expression *) let rec transl env e = @@ -577,6 +608,8 @@ let rec transl env e = (* Primitives *) | Uprim(prim, args, dbg) -> begin match (simplif_primitive prim, args) with + | (Pmake_unboxed_product layouts, args) -> + Ctuple (List.map (transl env) args) | (Pread_symbol sym, []) -> Cconst_symbol (global_symbol sym, dbg) | (Pmakeblock _, []) -> @@ -684,7 +717,8 @@ let rec transl env e = | Pasrbint _ | Pbintcomp (_, _) | Pstring_load _ | Pbytes_load _ | Pbytes_set _ | Pbigstring_load _ | Pbigstring_set _ | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _ - | Pbbswap _), _) + | Pbbswap _ + | Punboxed_product_field _), _) -> fatal_error "Cmmgen.transl:prim" end @@ -996,6 +1030,9 @@ and transl_prim_1 env p arg dbg = | Pbswap16 -> tag_int (bswap16 (ignore_high_bit_int (untag_int (transl env arg) dbg)) dbg) dbg + | Punboxed_product_field (field, layouts) -> + let layouts = Array.of_list (List.map machtype_of_layout layouts) in + Cop (Ctuple_field (field, layouts), [transl env arg], dbg) | (Pfield_computed | Psequand | Psequor | Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint @@ -1012,7 +1049,9 @@ and transl_prim_1 env p arg dbg = | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp (_, _) | Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _) | Pbigarraydim _ | Pstring_load _ | Pbytes_load _ | Pbytes_set _ - | Pbigstring_load _ | Pbigstring_set _ | Pprobe_is_enabled _) + | Pbigstring_load _ | Pbigstring_set _ | Pprobe_is_enabled _ + | Pmake_unboxed_product _ + ) -> fatal_errorf "Cmmgen.transl_prim_1: %a" Printclambda_primitives.primitive p @@ -1192,6 +1231,8 @@ and transl_prim_2 env p arg1 arg2 dbg = | Pbigarraydim _ | Pbytes_set _ | Pbigstring_set _ | Pbbswap _ | Pprobe_is_enabled _ | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _ + | Pmake_unboxed_product _ + | Punboxed_product_field _ -> fatal_errorf "Cmmgen.transl_prim_2: %a" Printclambda_primitives.primitive p @@ -1253,6 +1294,8 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg = | Pstring_load _ | Pbytes_load _ | Pbigstring_load _ | Pbbswap _ | Pprobe_is_enabled _ | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _ + | Pmake_unboxed_product _ + | Punboxed_product_field _ -> fatal_errorf "Cmmgen.transl_prim_3: %a" Printclambda_primitives.primitive p @@ -1326,6 +1369,7 @@ and transl_let env str (layout : Lambda.layout) id exp transl_body = there may be constant closures inside that need lifting out. *) let _cbody : expression = transl_body env in cexp + | Punboxed_product _ | Punboxed_float | Punboxed_int _ -> begin let cexp = transl env exp in let cbody = transl_body env in diff --git a/backend/printcmm.ml b/backend/printcmm.ml index 0b1e84e643e..f1ce5767f94 100644 --- a/backend/printcmm.ml +++ b/backend/printcmm.ml @@ -237,6 +237,8 @@ let operation d = function | Copaque -> "opaque" | Cbeginregion -> "beginregion" | Cendregion -> "endregion" + | Ctuple_field (field, _ty) -> + to_string "tuple_field %i" field let rec expr ppf = function diff --git a/backend/selectgen.ml b/backend/selectgen.ml index a985ef98a24..10e98cb9487 100644 --- a/backend/selectgen.ml +++ b/backend/selectgen.ml @@ -228,6 +228,7 @@ let oper_result_type = function naked pointer into the local allocation stack. *) typ_int | Cendregion -> typ_void + | Ctuple_field (field, fields_ty) -> fields_ty.(field) (* Infer the size in bytes of the result of an expression whose evaluation may be deferred (cf. [emit_parts]). *) @@ -499,6 +500,7 @@ method is_simple_expr = function | Ccsel _ | Cabsf | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat | Cvalueofint | Cintofvalue + | Ctuple_field _ | Ccmpf _ -> List.for_all self#is_simple_expr args end | Cassign _ | Cifthenelse _ | Cswitch _ | Ccatch _ | Cexit _ @@ -546,6 +548,7 @@ method effects_of exp = | Cload (_, Asttypes.Immutable) -> EC.none | Cload (_, Asttypes.Mutable) -> EC.coeffect_only Coeffect.Read_mutable | Cprobe_is_enabled _ -> EC.coeffect_only Coeffect.Arbitrary + | Ctuple_field _ | Caddi | Csubi | Cmuli | Cmulhi _ | Cdivi | Cmodi | Cand | Cor | Cxor | Cbswap _ | Ccsel _ @@ -917,6 +920,19 @@ method emit_expr_aux (env:environment) exp : let rs = self#emit_tuple env simple_args in ret (self#insert_op_debug env Iopaque dbg rs rs) end + | Cop(Ctuple_field(field, fields_layout), [arg], dbg) -> + begin match self#emit_expr env arg with + None -> None + | Some loc_exp -> + let flat_size a = Array.fold_left (fun acc t -> acc + Array.length t) 0 a in + assert(Array.length loc_exp = flat_size fields_layout); + let before = Array.sub fields_layout 0 field in + let size_before = flat_size before in + let field_slice = + Array.sub loc_exp size_before (Array.length fields_layout.(field)) + in + ret field_slice + end | Cop(op, args, dbg) -> begin match self#emit_parts_list env args with None -> None diff --git a/dune b/dune index 2eb7a7738a5..73587aa2aed 100755 --- a/dune +++ b/dune @@ -83,6 +83,7 @@ backend_var clambda clambda_primitives + clambda_layout compilenv mangling convert_primitives @@ -532,6 +533,7 @@ (backend_var.mli as compiler-libs/backend_var.mli) (clambda.mli as compiler-libs/clambda.mli) (clambda_primitives.mli as compiler-libs/clambda_primitives.mli) + (clambda_layout.mli as compiler-libs/clambda_layout.mli) (compilenv.mli as compiler-libs/compilenv.mli) (mangling.mli as compiler-libs/mangling.mli) (convert_primitives.mli as compiler-libs/convert_primitives.mli) diff --git a/middle_end/clambda_layout.ml b/middle_end/clambda_layout.ml new file mode 100644 index 00000000000..d529c844f34 --- /dev/null +++ b/middle_end/clambda_layout.ml @@ -0,0 +1,110 @@ +type atom = + | Value + | Value_int + | Unboxed_float + | Unboxed_int of Lambda.boxed_integer + +let rec fold_left_layout (f : 'acc -> 'e -> atom -> 'acc) + (acc : 'acc) (expr : Clambda.ulambda) (layout : Clambda_primitives.layout) : 'acc = + match layout with + | Ptop -> + Misc.fatal_error "[Ptop] can't be stored in a closure." + | Pbottom -> + Misc.fatal_error + "[Pbottom] should have been eliminated as dead code \ + and not stored in a closure." + | Punboxed_float -> f acc expr Unboxed_float + | Punboxed_int bi -> f acc expr (Unboxed_int bi) + | Pvalue Pintval -> f acc expr Value_int + | Pvalue _ -> f acc expr Value + | Punboxed_product layouts -> + List.fold_left (fun acc (field, layout) -> + let expr : Clambda.ulambda = + Uprim (Punboxed_product_field (field, layouts), [expr], Debuginfo.none) in + fold_left_layout f acc expr layout) acc + (List.mapi (fun i v -> i, v) layouts) + +type ('visible, 'invisible) decomposition' = + | Gc_visible of ('visible * atom) + | Gc_invisible of ('invisible * atom) + | Product of ('visible, 'invisible) decomposition' array + +type decomposition = + | Atom of { offset : int; layout : atom } + | Product of decomposition array + +let rec decompose (layout : Lambda.layout) : _ decomposition' = + match layout with + | Ptop -> + Misc.fatal_error "[Ptop] can't be stored in a closure." + | Pbottom -> + Misc.fatal_error + "[Pbottom] should have been eliminated as dead code \ + and not stored in a closure." + | Punboxed_float -> Gc_invisible ((), Unboxed_float) + | Punboxed_int bi -> Gc_invisible ((), Unboxed_int bi) + | Pvalue Pintval -> Gc_invisible ((), Value_int) + | Pvalue _ -> Gc_visible ((), Value) + | Punboxed_product l -> + Product (Array.of_list (List.map decompose l)) + +let rec solidify (dec : (int, int) decomposition') : decomposition = + match dec with + | Gc_visible (offset, layout) -> Atom { offset; layout } + | Gc_invisible (offset, layout) -> Atom { offset; layout } + | Product a -> + Product (Array.map solidify a) + +let rec fold_decompose + (f1 : 'acc -> 'a -> atom -> 'acc * 'b) (f2 : 'acc -> 'c -> atom -> 'acc * 'd) + (acc : 'acc) (d : ('a, 'c) decomposition') : + 'acc * ('b, 'd) decomposition' = + match d with + | Gc_visible (v, layout) -> + let acc, v = f1 acc v layout in + acc, Gc_visible (v, layout) + | Gc_invisible (v, layout) -> + let acc, v = f2 acc v layout in + acc, Gc_invisible (v, layout) + | Product elts -> + let acc, elts = Array.fold_left_map (fold_decompose f1 f2) acc elts in + acc, Product elts + +let atom_size (layout : atom) = + match layout with + | Value + | Value_int + | Unboxed_float + | Unboxed_int _ -> 1 + +let assign_invisible_offsets init_pos (var, dec) = + let f_visible acc () _layout = + acc, () + in + let f_invisible acc () layout = + acc + atom_size layout, acc + in + let acc, dec = fold_decompose f_visible f_invisible init_pos dec in + acc, (var, dec) + +let assign_visible_offsets init_pos (var, dec) = + let f_visible acc () layout = + acc + atom_size layout, acc + in + let f_invisible acc off _layout = + acc, off + in + let acc, dec = fold_decompose f_visible f_invisible init_pos dec in + acc, (var, solidify dec) + +let decompose_free_vars ~base_offset ~free_vars = + let free_vars = + List.map (fun (var, kind) -> var, decompose kind) free_vars + in + let base_offset, free_vars = + List.fold_left_map assign_invisible_offsets base_offset free_vars + in + let _base_offset, free_vars = + List.fold_left_map assign_visible_offsets base_offset free_vars + in + free_vars diff --git a/middle_end/clambda_layout.mli b/middle_end/clambda_layout.mli new file mode 100644 index 00000000000..d145595a6ab --- /dev/null +++ b/middle_end/clambda_layout.mli @@ -0,0 +1,18 @@ +type atom = + | Value + | Value_int + | Unboxed_float + | Unboxed_int of Lambda.boxed_integer + +val fold_left_layout : + ('acc -> Clambda.ulambda -> atom -> 'acc) -> 'acc -> Clambda.ulambda -> + Clambda_primitives.layout -> 'acc + +type decomposition = + | Atom of { offset : int; layout : atom } + | Product of decomposition array + +val decompose_free_vars : + base_offset:int -> + free_vars:('a * Clambda_primitives.layout) list -> + ('a * decomposition) list diff --git a/middle_end/clambda_primitives.ml b/middle_end/clambda_primitives.ml index 77e66745305..ff5dd06b030 100644 --- a/middle_end/clambda_primitives.ml +++ b/middle_end/clambda_primitives.ml @@ -126,6 +126,9 @@ type primitive = | Pbox_float of alloc_mode | Punbox_int of boxed_integer | Pbox_int of boxed_integer * alloc_mode + (* Unboxed products *) + | Pmake_unboxed_product of layout list + | Punboxed_product_field of int * (layout list) and integer_comparison = Lambda.integer_comparison = Ceq | Cne | Clt | Cgt | Cle | Cge @@ -150,6 +153,7 @@ and layout = Lambda.layout = | Pvalue of value_kind | Punboxed_float | Punboxed_int of boxed_integer + | Punboxed_product of layout list | Pbottom and block_shape = Lambda.block_shape @@ -181,4 +185,6 @@ let result_layout (p : primitive) = match p with | Punbox_float -> Lambda.Punboxed_float | Punbox_int bi -> Lambda.Punboxed_int bi + | Pmake_unboxed_product layouts -> Lambda.Punboxed_product layouts + | Punboxed_product_field (field, layouts) -> List.nth layouts field | _ -> Lambda.layout_any_value diff --git a/middle_end/clambda_primitives.mli b/middle_end/clambda_primitives.mli index e71b17c4c85..609a4f8d2fb 100644 --- a/middle_end/clambda_primitives.mli +++ b/middle_end/clambda_primitives.mli @@ -129,6 +129,9 @@ type primitive = | Pbox_float of alloc_mode | Punbox_int of boxed_integer | Pbox_int of boxed_integer * alloc_mode + (* Unboxed products *) + | Pmake_unboxed_product of layout list + | Punboxed_product_field of int * (layout list) and integer_comparison = Lambda.integer_comparison = Ceq | Cne | Clt | Cgt | Cle | Cge @@ -153,6 +156,7 @@ and layout = Lambda.layout = | Pvalue of value_kind | Punboxed_float | Punboxed_int of boxed_integer + | Punboxed_product of layout list | Pbottom and block_shape = Lambda.block_shape diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml index 87b13e0875b..37c09fdaa22 100644 --- a/middle_end/closure/closure.ml +++ b/middle_end/closure/closure.ml @@ -50,29 +50,53 @@ let rec split_list n l = | a::l -> let (l1, l2) = split_list (n-1) l in (a::l1, l2) end -let rec add_to_closure_env env_param pos cenv = function - [] -> cenv - | (id, kind) :: rem -> - V.Map.add id - (Uprim(P.Pfield (pos, kind), [Uvar env_param], Debuginfo.none)) - (add_to_closure_env env_param (pos+1) cenv rem) - -let is_gc_ignorable kind = - match kind with - | Ptop -> Misc.fatal_error "[Ptop] can't be stored in a closure." - | Pbottom -> Misc.fatal_error "[Pbottom] should not be stored in a closure." - | Punboxed_float -> true - | Punboxed_int _ -> true - | Pvalue Pintval -> true - | Pvalue (Pgenval | Pfloatval | Pboxedintval _ | Pvariant _ | Parrayval _) -> false - let split_closure_fv kinds fv = - List.fold_right (fun id (not_scanned, scanned) -> - let kind = V.Map.find id kinds in - if is_gc_ignorable kind - then ((id, kind) :: not_scanned, scanned) - else (not_scanned, (id, kind)::scanned)) - fv ([], []) + let (not_scanned_fv, scanned_fv) = + List.fold_left (fun acc id -> + let kind = V.Map.find id kinds in + let f (not_scanned_fv, scanned_fv) expr (atom : Clambda_layout.atom) = + match atom with + | Value -> not_scanned_fv, ((expr, atom) :: scanned_fv) + | Value_int | Unboxed_float | Unboxed_int _ -> + ((expr, atom) :: not_scanned_fv, scanned_fv) + in + Clambda_layout.fold_left_layout f acc (Uvar id) kind) + ([],[]) fv + in + (List.rev not_scanned_fv, List.rev scanned_fv) + +let layout_of_atom (atom : Closure_offsets.layout_atom) : Lambda.layout = + match atom with + | Value -> Pvalue Pgenval + | Value_int -> Pvalue Pintval + | Unboxed_float -> Punboxed_float + | Unboxed_int bi -> Punboxed_int bi + +let load_env_field ~base_offset + ~closure (parts : Clambda_layout.decomposition) : Clambda.ulambda = + let rec rebuild (parts : Closure_offsets.parts) : Clambda.ulambda * Clambda_primitives.layout = + match parts with + | Atom { offset = var_offset; layout } -> + let pos = var_offset + base_offset in + let layout = layout_of_atom layout in + Uprim (Pfield (pos, layout), [closure], Debuginfo.none), layout + | Product parts -> + let parts = Array.to_list @@ Array.map rebuild parts in + let parts, layouts = List.split parts in + Uprim (Pmake_unboxed_product layouts, parts, Debuginfo.none), + Punboxed_product layouts + in + let expr, _layout = rebuild parts in + expr + +let add_to_closure_env env_param base_offset fv = + List.fold_left (fun cenv (id, decomp) -> + let expr = + load_env_field ~base_offset ~closure:(Uvar env_param) + decomp + in + V.Map.add id expr cenv) + V.Map.empty fv (* Auxiliary for accessing globals. We change the name of the global to the name of the corresponding asm symbol. This is done here @@ -1504,7 +1528,7 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ let fv = V.Set.elements (free_variables (Lletrec(fun_defs, lambda_unit))) in let not_scanned_fv, scanned_fv = split_closure_fv kinds fv in - let not_scanned_fv_size = List.length not_scanned_fv in + let free_vars = List.map (fun id -> id, V.Map.find id kinds) fv in (* Build the function descriptors for the functions. Initially all functions are assumed not to need their environment parameter. *) @@ -1566,13 +1590,13 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ (* Translate each function definition *) let clos_fundef (id, params, return, body, mode, check, fundesc, dbg) env_pos = let env_param = V.create_local "env" in - let cenv_fv = - add_to_closure_env env_param - (fv_pos - env_pos) V.Map.empty not_scanned_fv + let decomposition = + Clambda_layout.decompose_free_vars + ~base_offset:0 + ~free_vars in let cenv_fv = - add_to_closure_env env_param - (fv_pos - env_pos + not_scanned_fv_size) cenv_fv scanned_fv + add_to_closure_env env_param (fv_pos - env_pos) decomposition in let cenv_body = List.fold_right2 @@ -1669,11 +1693,10 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ let (clos, infos) = List.split clos_info_list in let not_scanned_fv, scanned_fv = if !useless_env then [], [] else not_scanned_fv, scanned_fv in - let env = { backend; fenv; cenv; mutable_vars; kinds; catch_env } in (Uclosure { functions = clos; - not_scanned_slots = List.map (fun (id, _kind) -> close_var env id) not_scanned_fv; - scanned_slots = List.map (fun (id, _kind) -> close_var env id) scanned_fv + not_scanned_slots = List.map (fun (expr, _kind) -> expr) not_scanned_fv; + scanned_slots = List.map (fun (expr, _kind) -> expr) scanned_fv }, infos) diff --git a/middle_end/convert_primitives.ml b/middle_end/convert_primitives.ml index 541af7ecf86..0c8f8435d30 100644 --- a/middle_end/convert_primitives.ml +++ b/middle_end/convert_primitives.ml @@ -38,6 +38,9 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive = | Psetfloatfield (field, init_or_assign) -> Psetfloatfield (field, init_or_assign) | Pduprecord (repr, size) -> Pduprecord (repr, size) + | Pmake_unboxed_product layouts -> Pmake_unboxed_product layouts + | Punboxed_product_field (field, layouts) -> + Punboxed_product_field (field, layouts) | Pccall prim -> Pccall prim | Praise kind -> Praise kind | Psequand -> Psequand diff --git a/middle_end/flambda/closure_offsets.ml b/middle_end/flambda/closure_offsets.ml index cfb1791786d..19e4522ff4c 100644 --- a/middle_end/flambda/closure_offsets.ml +++ b/middle_end/flambda/closure_offsets.ml @@ -16,9 +16,18 @@ [@@@ocaml.warning "+a-4-9-30-40-41-42"] +type layout_atom = Clambda_layout.atom + +type decomposition = Clambda_layout.decomposition +type parts = decomposition + +let equal_parts (p1 : parts) p2 = p1 = p2 +let print_parts ppf _p = + Format.fprintf ppf "TODO offset parts" + type result = { function_offsets : int Closure_id.Map.t; - free_variable_offsets : int Var_within_closure.Map.t; + free_variable_offsets : parts Var_within_closure.Map.t; } let add_closure_offsets @@ -58,38 +67,19 @@ let add_closure_offsets accesses. *) (* CR-someday mshinwell: As discussed with lwhite, maybe this isn't ideal, and the self accesses should be explicitly marked too. *) - let assign_free_variable_offset var _ (map, pos) = - let var_within_closure = Var_within_closure.wrap var in - if Var_within_closure.Map.mem var_within_closure map then begin - Misc.fatal_errorf "Closure_offsets.add_closure_offsets: free variable \ - offset for %a would be defined multiple times" - Var_within_closure.print var_within_closure - end; - let map = Var_within_closure.Map.add var_within_closure pos map in - (map, pos + 1) - in - let gc_invisible_free_vars, gc_visible_free_vars = - Variable.Map.partition (fun _ (free_var : Flambda.specialised_to) -> - match free_var.kind with - | Ptop -> - Misc.fatal_error "[Ptop] can't be stored in a closure." - | Pbottom -> - Misc.fatal_error - "[Pbottom] should have been eliminated as dead code \ - and not stored in a closure." - | Punboxed_float -> true - | Punboxed_int _ -> true - | Pvalue Pintval -> true - | Pvalue _ -> false) - free_vars - in - let free_variable_offsets, free_variable_pos = - Variable.Map.fold assign_free_variable_offset - gc_invisible_free_vars (free_variable_offsets, free_variable_pos) + let free_vars = Variable.Map.bindings free_vars in + let free_vars = List.map (fun (var, (free_var : Flambda.specialised_to)) -> + var, free_var.kind) free_vars in + let free_vars = + Clambda_layout.decompose_free_vars + ~base_offset:free_variable_pos + ~free_vars in - let free_variable_offsets, _ = - Variable.Map.fold assign_free_variable_offset - gc_visible_free_vars (free_variable_offsets, free_variable_pos) + let free_variable_offsets = + List.fold_left (fun map (var, dec) -> + let var_within_closure = Var_within_closure.wrap var in + Var_within_closure.Map.add var_within_closure dec map) + free_variable_offsets free_vars in { function_offsets; free_variable_offsets; diff --git a/middle_end/flambda/closure_offsets.mli b/middle_end/flambda/closure_offsets.mli index 7ecf9c276d2..858f7ebc59b 100644 --- a/middle_end/flambda/closure_offsets.mli +++ b/middle_end/flambda/closure_offsets.mli @@ -19,9 +19,16 @@ (** Assign numerical offsets, within closure blocks, for code pointers and environment entries. *) +type layout_atom = Clambda_layout.atom + +type parts = Clambda_layout.decomposition + +val equal_parts : parts -> parts -> bool +val print_parts : Format.formatter -> parts -> unit + type result = private { function_offsets : int Closure_id.Map.t; - free_variable_offsets : int Var_within_closure.Map.t; + free_variable_offsets : parts Var_within_closure.Map.t; } val compute : Flambda.program -> result diff --git a/middle_end/flambda/export_info.ml b/middle_end/flambda/export_info.ml index 510a6f4b252..dffd12dc98e 100644 --- a/middle_end/flambda/export_info.ml +++ b/middle_end/flambda/export_info.ml @@ -142,7 +142,7 @@ type t = { values : descr Export_id.Map.t Compilation_unit.Map.t; symbol_id : Export_id.t Symbol.Map.t; offset_fun : int Closure_id.Map.t; - offset_fv : int Var_within_closure.Map.t; + offset_fv : Closure_offsets.parts Var_within_closure.Map.t; constant_closures : Closure_id.Set.t; invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t; recursive : Variable.Set.t Set_of_closures_id.Map.t; @@ -291,7 +291,7 @@ let merge (t1 : t) (t2 : t) : t = offset_fun = Closure_id.Map.disjoint_union ~eq:int_eq t1.offset_fun t2.offset_fun; offset_fv = Var_within_closure.Map.disjoint_union - ~eq:int_eq t1.offset_fv t2.offset_fv; + ~eq:Closure_offsets.equal_parts t1.offset_fv t2.offset_fv; constant_closures = Closure_id.Set.union t1.constant_closures t2.constant_closures; invariant_params = @@ -544,8 +544,9 @@ let print_offsets ppf (t : t) = Closure_id.print cid off) t.offset_fun; Format.fprintf ppf "@]@ @[offset_fv:@ "; Var_within_closure.Map.iter (fun vid off -> - Format.fprintf ppf "%a -> %i@ " - Var_within_closure.print vid off) t.offset_fv; + Format.fprintf ppf "%a -> %a@ " + Var_within_closure.print vid + Closure_offsets.print_parts off) t.offset_fv; Format.fprintf ppf "@]@ " let print_functions ppf (t : t) = diff --git a/middle_end/flambda/export_info.mli b/middle_end/flambda/export_info.mli index 6b53dd75ea5..a70b894e95a 100644 --- a/middle_end/flambda/export_info.mli +++ b/middle_end/flambda/export_info.mli @@ -87,7 +87,7 @@ type t = private { (** Associates symbols and values. *) offset_fun : int Closure_id.Map.t; (** Positions of function pointers in their closures. *) - offset_fv : int Var_within_closure.Map.t; + offset_fv : Closure_offsets.parts Var_within_closure.Map.t; (** Positions of value pointers in their closures. *) constant_closures : Closure_id.Set.t; (* CR-soon mshinwell for pchambart: Add comment *) @@ -123,7 +123,7 @@ val create -> values:descr Export_id.Map.t Compilation_unit.Map.t -> symbol_id:Export_id.t Symbol.Map.t -> offset_fun:int Closure_id.Map.t - -> offset_fv:int Var_within_closure.Map.t + -> offset_fv:Closure_offsets.parts Var_within_closure.Map.t -> constant_closures:Closure_id.Set.t -> invariant_params:Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t -> recursive:Variable.Set.t Set_of_closures_id.Map.t @@ -154,9 +154,9 @@ val t_of_transient : transient -> program: Flambda.program -> local_offset_fun:int Closure_id.Map.t - -> local_offset_fv:int Var_within_closure.Map.t + -> local_offset_fv:Closure_offsets.parts Var_within_closure.Map.t -> imported_offset_fun:int Closure_id.Map.t - -> imported_offset_fv:int Var_within_closure.Map.t + -> imported_offset_fv:Closure_offsets.parts Var_within_closure.Map.t -> constant_closures:Closure_id.Set.t -> t diff --git a/middle_end/flambda/flambda_to_clambda.ml b/middle_end/flambda/flambda_to_clambda.ml index 7e25f986854..f26d5435fc0 100644 --- a/middle_end/flambda/flambda_to_clambda.ml +++ b/middle_end/flambda/flambda_to_clambda.ml @@ -22,7 +22,7 @@ module Int = Misc.Stdlib.Int type 'a for_one_or_more_units = { fun_offset_table : int Closure_id.Map.t; - fv_offset_table : int Var_within_closure.Map.t; + fv_offset_table : Closure_offsets.parts Var_within_closure.Map.t; constant_closures : Closure_id.Set.t; closures: Closure_id.Set.t; } @@ -244,6 +244,30 @@ let to_clambda_const env (const : Flambda.constant_defining_value_block_field) | Const (Int i) -> Uconst_int i | Const (Char c) -> Uconst_int (Char.code c) +let layout_of_atom (atom : Closure_offsets.layout_atom) : Lambda.layout = + match atom with + | Value -> Pvalue Pgenval + | Value_int -> Pvalue Pintval + | Unboxed_float -> Punboxed_float + | Unboxed_int bi -> Punboxed_int bi + +let load_env_field ~fun_offset + ~closure_using_field (parts : Closure_offsets.parts) : Clambda.ulambda = + let rec rebuild (parts : Closure_offsets.parts) : Clambda.ulambda * Clambda_primitives.layout = + match parts with + | Atom { offset = var_offset; layout } -> + let pos = var_offset - fun_offset in + let layout = layout_of_atom layout in + Uprim (Pfield (pos, layout), [closure_using_field pos], Debuginfo.none), layout + | Product parts -> + let parts = Array.to_list @@ Array.map rebuild parts in + let parts, layouts = List.split parts in + Uprim (Pmake_unboxed_product layouts, parts, Debuginfo.none), + Punboxed_product layouts + in + let expr, _layout = rebuild parts in + expr + let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda * Lambda.layout = match flam with | Var var -> subst_var env var @@ -499,16 +523,17 @@ and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda * Lambd ((get_fun_offset t move_to) - (get_fun_offset t start_from))) named, Lambda.layout_function - | Project_var { closure; var; closure_id; kind } -> - let ulam, _closure_layout = subst_var env closure in - let fun_offset = get_fun_offset t closure_id in - let var_offset = get_fv_offset t var in - let pos = var_offset - fun_offset in - Uprim (Pfield (pos, kind), - [check_field t (check_closure t ulam (Expr (Var closure))) - pos (Some named)], - Debuginfo.none), - kind + | Project_var { closure; var; closure_id; kind } -> begin + let ulam, _closure_layout = subst_var env closure in + let fun_offset = get_fun_offset t closure_id in + let var_offset = get_fv_offset t var in + let check_field pos = + check_field t (check_closure t ulam (Expr (Var closure))) + pos (Some named) + in + load_env_field ~fun_offset ~closure_using_field:check_field var_offset, + kind + end | Prim (Pfield (index, layout), [block], dbg) -> begin match layout with | Pvalue _ -> () @@ -655,10 +680,11 @@ and to_clambda_set_of_closures t env Variable.print id Flambda.print_set_of_closures set_of_closures in - let pos = var_offset - fun_offset in - Env.add_subst env id - (Uprim (Pfield (pos, spec_to.kind), [Clambda.Uvar env_var], Debuginfo.none)) - spec_to.kind + let expr = + let closure_using_field _pos = Clambda.Uvar env_var in + load_env_field ~fun_offset ~closure_using_field var_offset + in + Env.add_subst env id expr spec_to.kind in let env = Variable.Map.fold add_env_free_variable free_vars env in (* Add the Clambda expressions for all functions defined in the current @@ -703,33 +729,22 @@ and to_clambda_set_of_closures t env in let functions = List.map to_clambda_function all_functions in let not_scanned_fv, scanned_fv = - Variable.Map.partition (fun _ (free_var : Flambda.specialised_to) -> - match free_var.kind with - | Ptop -> Misc.fatal_error "[Ptop] can't be stored in a closure." - | Pbottom -> - Misc.fatal_error - "[Pbottom] should have been eliminated as dead code \ - and not stored in a closure." - | Punboxed_float -> true - | Punboxed_int _ -> true - | Pvalue Pintval -> true - | Pvalue _ -> false) - free_vars - in - let to_closure_args free_vars = - List.map snd ( - Variable.Map.bindings (Variable.Map.map ( - fun (free_var : Flambda.specialised_to) -> - let var, var_layout = subst_var env free_var.var in - assert(Lambda.compatible_layout var_layout free_var.kind); - var - ) free_vars)) + let free_vars = Variable.Map.bindings free_vars in + List.fold_left (fun acc (_var, (free_var : Flambda.specialised_to)) -> + let f (not_scanned_fv, scanned_fv) + (expr: Clambda.ulambda) (atom : Closure_offsets.layout_atom) = + match atom with + | Value -> not_scanned_fv, (expr :: scanned_fv) + | Value_int | Unboxed_float | Unboxed_int _ -> + (expr :: not_scanned_fv, scanned_fv) + in + let closure, var_layout = subst_var env free_var.var in + assert(Lambda.compatible_layout var_layout free_var.kind); + Clambda_layout.fold_left_layout f acc closure free_var.kind + ) ([],[]) free_vars in - Uclosure { - functions ; - not_scanned_slots = to_closure_args not_scanned_fv ; - scanned_slots = to_closure_args scanned_fv - } + let not_scanned_slots, scanned_slots = List.rev not_scanned_fv, List.rev scanned_fv in + Uclosure { functions; not_scanned_slots; scanned_slots; } and to_clambda_closed_set_of_closures t env symbol ({ function_decls; } : Flambda.set_of_closures) diff --git a/middle_end/flambda2/bound_identifiers/bound_parameters.ml b/middle_end/flambda2/bound_identifiers/bound_parameters.ml index 99498cc3d07..9cc4bb1d2ed 100644 --- a/middle_end/flambda2/bound_identifiers/bound_parameters.ml +++ b/middle_end/flambda2/bound_identifiers/bound_parameters.ml @@ -58,7 +58,11 @@ let var_set t = Variable.Set.of_list (vars t) let rename t = List.map (fun t -> BP.rename t) t -let arity t = List.map (fun t -> BP.kind t) t |> Flambda_arity.create +let arity t = + List.map + (fun t -> Flambda_arity.Component_for_creation.Singleton (BP.kind t)) + t + |> Flambda_arity.create let free_names t = List.fold_left diff --git a/middle_end/flambda2/bound_identifiers/bound_parameters.mli b/middle_end/flambda2/bound_identifiers/bound_parameters.mli index 82460e86e9a..9001ea45c73 100644 --- a/middle_end/flambda2/bound_identifiers/bound_parameters.mli +++ b/middle_end/flambda2/bound_identifiers/bound_parameters.mli @@ -30,7 +30,7 @@ val is_empty : t -> bool val same_number : t -> t -> bool -val arity : t -> Flambda_arity.t +val arity : t -> [> ] Flambda_arity.t val check_no_duplicates : t -> unit diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml index d7912d3685d..91af6558cc2 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion.ml @@ -238,7 +238,7 @@ module Inlining = struct | Some (Closure_approximation { code; _ }) -> let metadata = Code_or_metadata.code_metadata code in let fun_params_length = - Code_metadata.params_arity metadata |> Flambda_arity.cardinal + Code_metadata.params_arity metadata |> Flambda_arity.num_params in if (not (Code_or_metadata.code_present code)) || fun_params_length > List.length (Apply_expr.args apply) @@ -440,11 +440,11 @@ let close_c_call acc env ~loc ~let_bound_var let param_arity = List.map kind_of_primitive_native_repr prim_native_repr_args |> List.map K.With_subkind.anything - |> Flambda_arity.create + |> Flambda_arity.create_singletons in let return_kind = kind_of_primitive_native_repr prim_native_repr_res in let return_arity = - Flambda_arity.create [K.With_subkind.anything return_kind] + Flambda_arity.create_singletons [K.With_subkind.anything return_kind] in let call_kind = Call_kind.c_call ~alloc:prim_alloc ~is_c_builtin:prim_c_builtin @@ -598,9 +598,32 @@ let close_exn_continuation acc env (exn_continuation : IR.exn_continuation) = Exn_continuation.create ~exn_handler:exn_continuation.exn_handler ~extra_args ) +let close_raise acc env ~raise_kind ~arg loc exn_continuation = + let acc, exn_cont = close_exn_continuation acc env exn_continuation in + let exn_handler = Exn_continuation.exn_handler exn_cont in + let acc, arg = find_simple acc env arg in + let args = + (* CR mshinwell: Share with [Lambda_to_flambda_primitives_helpers] *) + let extra_args = + List.map + (fun (simple, _kind) -> simple) + (Exn_continuation.extra_args exn_cont) + in + arg :: extra_args + in + let raise_kind = Some (Trap_action.Raise_kind.from_lambda raise_kind) in + let trap_action = Trap_action.Pop { exn_handler; raise_kind } in + let dbg = Debuginfo.from_location loc in + let acc, apply_cont = + Apply_cont_with_acc.create acc ~trap_action exn_handler ~args ~dbg + in + (* Since raising of an exception doesn't terminate, we don't call [k]. *) + Expr_with_acc.create_apply_cont acc apply_cont + let close_primitive acc env ~let_bound_var named (prim : Lambda.primitive) ~args loc (exn_continuation : IR.exn_continuation option) ~current_region (k : Acc.t -> Named.t option -> Expr_with_acc.t) : Expr_with_acc.t = + let orig_exn_continuation = exn_continuation in let acc, exn_continuation = match exn_continuation with | None -> acc, None @@ -608,6 +631,7 @@ let close_primitive acc env ~let_bound_var named (prim : Lambda.primitive) ~args let acc, cont = close_exn_continuation acc env exn_continuation in acc, Some cont in + let orig_args = args in let acc, args = find_simples acc env args in let dbg = Debuginfo.from_location loc in match prim, args with @@ -639,29 +663,14 @@ let close_primitive acc env ~let_bound_var named (prim : Lambda.primitive) ~args k acc (Some named) | Praise raise_kind, [_] -> let exn_continuation = - match exn_continuation with + match orig_exn_continuation with | None -> Misc.fatal_errorf "Praise is missing exception continuation: %a" IR.print_named named | Some exn_continuation -> exn_continuation in - let exn_handler = Exn_continuation.exn_handler exn_continuation in - let args = - (* CR mshinwell: Share with [Lambda_to_flambda_primitives_helpers] *) - let extra_args = - List.map - (fun (simple, _kind) -> simple) - (Exn_continuation.extra_args exn_continuation) - in - args @ extra_args - in - let raise_kind = Some (Trap_action.Raise_kind.from_lambda raise_kind) in - let trap_action = Trap_action.Pop { exn_handler; raise_kind } in - let acc, apply_cont = - Apply_cont_with_acc.create acc ~trap_action exn_handler ~args ~dbg - in - (* Since raising of an exception doesn't terminate, we don't call [k]. *) - Expr_with_acc.create_apply_cont acc apply_cont + close_raise acc env ~raise_kind ~arg:(List.hd orig_args) loc + exn_continuation | (Pmakeblock _ | Pmakefloatblock _ | Pmakearray _), [] -> (* Special case for liftable empty block or array *) let acc, sym = @@ -704,7 +713,7 @@ let close_primitive acc env ~let_bound_var named (prim : Lambda.primitive) ~args | Pbigstring_set_64 _ | Pctconst _ | Pbswap16 | Pbbswap _ | Pint_as_pointer | Popaque _ | Pprobe_is_enabled _ | Pobj_dup | Pobj_magic _ | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _ - -> + | Pmake_unboxed_product _ | Punboxed_product_field _ -> (* Inconsistent with outer match *) assert false in @@ -1058,6 +1067,7 @@ let close_exact_or_unknown_apply acc env mode; region_close; region; + args_arity; return_arity } : IR.apply) callee_approx ~replace_region : Expr_with_acc.t = @@ -1101,7 +1111,7 @@ let close_exact_or_unknown_apply acc env close_exn_continuation acc env exn_continuation in let acc, args_with_arity = find_simples_and_arity acc env args in - let args, args_arity = List.split args_with_arity in + let args, _split_args_arity = List.split args_with_arity in let inlined_call = Inlined_attribute.from_lambda inlined in let probe = Probe.from_lambda probe in let position = @@ -1111,9 +1121,9 @@ let close_exact_or_unknown_apply acc env in let apply = Apply.create ~callee ~continuation:(Return continuation) - apply_exn_continuation ~args - ~args_arity:(Flambda_arity.create args_arity) - ~return_arity ~call_kind + apply_exn_continuation ~args ~args_arity + ~return_arity:(Flambda_arity.unarize_t return_arity) + ~call_kind (Debuginfo.from_location loc) ~inlined:inlined_call ~inlining_state:(Inlining_state.default ~round:0) @@ -1519,7 +1529,7 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot decl (Exn_continuation.exn_handler exn_continuation) in let closure_info, acc = Acc.pop_closure_info acc in - let params_arity = Bound_parameters.arity params in + let params_arity = Function_decl.params_arity decl in let is_tupled = match Function_decl.kind decl with Curried _ -> false | Tupled -> true in @@ -1543,7 +1553,8 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot decl Code.create code_id ~params_and_body ~free_names_of_params_and_body:(Acc.free_names acc) ~params_arity ~num_trailing_local_params:(Function_decl.num_trailing_local_params decl) - ~result_arity:return ~result_types:Unknown + ~result_arity:(Flambda_arity.unarize_t return) + ~result_types:Unknown ~contains_no_escaping_local_allocs: (Function_decl.contains_no_escaping_local_allocs decl) ~stub ~inline @@ -1651,7 +1662,8 @@ let close_functions acc external_env ~current_region function_declarations = let code_id = Function_slot.Map.find function_slot function_code_ids in let params = Function_decl.params decl in let params_arity = - List.map (fun (_, kind) -> kind) params |> Flambda_arity.create + List.map (fun (_, kind) -> kind) params + |> Flambda_arity.create_singletons in let result_arity = Function_decl.return decl in let poll_attribute = @@ -1671,7 +1683,8 @@ let close_functions acc external_env ~current_region function_declarations = Code_metadata.create code_id ~params_arity ~num_trailing_local_params: (Function_decl.num_trailing_local_params decl) - ~result_arity ~result_types:Unknown + ~result_arity:(Flambda_arity.unarize_t result_arity) + ~result_types:Unknown ~contains_no_escaping_local_allocs: (Function_decl.contains_no_escaping_local_allocs decl) ~stub:(Function_decl.stub decl) ~inline:Never_inline ~check @@ -1969,8 +1982,18 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply) (fun n kind_with_subkind -> ( Ident.create_local ("param" ^ string_of_int (num_provided + n)), kind_with_subkind )) - (Flambda_arity.to_list missing_arity) - in + (Flambda_arity.unarize missing_arity) + in + let params_arity = missing_arity in + (match Sys.getenv "DEBUG" with + | exception Not_found -> () + | _ -> + Format.eprintf + "partial application (in CC) of %a: old params arity is %a, new params \ + arity is %a\n\ + %!" + Ident.print apply.func Flambda_arity.print arity Flambda_arity.print + params_arity); let return_continuation = Continuation.create ~sort:Return () in let exn_continuation = IR.{ exn_handler = Continuation.create (); extra_args = [] } @@ -1986,6 +2009,7 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply) { apply with kind = Function; args = all_args; + args_arity = arity; continuation = return_continuation; exn_continuation; inlined = Lambda.Default_inlined; @@ -2016,7 +2040,10 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply) in let closure_alloc_mode, num_trailing_local_params = let num_leading_heap_params = - Flambda_arity.cardinal arity - num_trailing_local_params + (* This is a pre-unarization calculation so uses [num_params] not + [cardinal_unarized]. *) + (* CR mshinwell: check this is correct *) + Flambda_arity.num_params arity - num_trailing_local_params in if num_provided <= num_leading_heap_params then Lambda.alloc_heap, num_trailing_local_params @@ -2032,11 +2059,11 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply) let function_declarations = [ Function_decl.create ~let_rec_ident:(Some wrapper_id) ~function_slot ~kind:(Lambda.Curried { nlocal = num_trailing_local_params }) - ~params ~return:apply.return_arity ~return_continuation - ~exn_continuation ~my_region:apply.region ~body:fbody ~attr - ~loc:apply.loc ~free_idents_of_body ~closure_alloc_mode - ~num_trailing_local_params ~contains_no_escaping_local_allocs - Recursive.Non_recursive ] + ~params ~params_arity ~removed_params:Ident.Set.empty + ~return:apply.return_arity ~return_continuation ~exn_continuation + ~my_region:apply.region ~body:fbody ~attr ~loc:apply.loc + ~free_idents_of_body ~closure_alloc_mode ~num_trailing_local_params + ~contains_no_escaping_local_allocs Recursive.Non_recursive ] in let body acc env = let arg = find_simple_from_id env wrapper_id in @@ -2052,6 +2079,13 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply) let wrap_over_application acc env full_call (apply : IR.apply) ~remaining ~remaining_arity ~contains_no_escaping_local_allocs = + (* Format.eprintf "wrap_over_application of %a, args %a, args_arity(apply)=%a, + \ result_arity(apply)=%a@ remaining=(%a)@ remaining_arity=%a\n\ %!" + Ident.print apply.func (Format.pp_print_list ~pp_sep:Format.pp_print_space + IR.print_simple) apply.args (Misc.Stdlib.Option.print Flambda_arity.print) + apply.args_arity Flambda_arity.print apply.return_arity + (Format.pp_print_list ~pp_sep:Format.pp_print_space IR.print_simple) + remaining Flambda_arity.print remaining_arity; *) let wrapper_cont = Continuation.create () in let returned_func = Variable.create "func" in (* See comments in [Simplify_common.split_direct_over_application] about this @@ -2097,7 +2131,8 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining let over_application = Apply.create ~callee:(Simple.var returned_func) ~continuation apply_exn_continuation ~args:remaining ~args_arity:remaining_arity - ~return_arity:apply.return_arity ~call_kind apply_dbg ~inlined + ~return_arity:(Flambda_arity.unarize_t apply.return_arity) + ~call_kind apply_dbg ~inlined ~inlining_state:(Inlining_state.default ~round:0) ~probe ~position ~relative_history:(Env.relative_history_from_scoped ~loc:apply.loc env) @@ -2110,7 +2145,7 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining List.mapi (fun i kind -> BP.create (Variable.create ("result" ^ string_of_int i)) kind) - (Flambda_arity.to_list apply.return_arity) + (Flambda_arity.unarize apply.return_arity) in let handler acc = let acc, call_return_continuation = @@ -2153,12 +2188,13 @@ type call_args_split = | Exact of IR.simple list | Partial_app of { provided : IR.simple list; - missing_arity : Flambda_arity.t + missing_arity : [`Complex] Flambda_arity.t } | Over_app of { full : IR.simple list; + provided_arity : [`Complex] Flambda_arity.t; remaining : IR.simple list; - remaining_arity : Flambda_arity.t + remaining_arity : [`Complex] Flambda_arity.t } let close_apply acc env (apply : IR.apply) : Expr_with_acc.t = @@ -2190,10 +2226,19 @@ let close_apply acc env (apply : IR.apply) : Expr_with_acc.t = is_tupled, num_trailing_local_params, contains_no_escaping_local_allocs ) -> ( - let acc, args_with_arities = find_simples_and_arity acc env apply.args in - let args_arity = List.map snd args_with_arities in + let acc, _ = find_simples_and_arity acc env apply.args in let split_args = - let arity = Flambda_arity.to_list arity in + let non_unarized_arity, arity = + let arity = + if is_tupled + then + Flambda_arity.create_singletons + [ Flambda_kind.With_subkind.block Tag.zero + (Flambda_arity.unarize arity) ] + else arity + in + arity, Flambda_arity.unarize arity + in let split args arity = let rec cut n l = if n <= 0 @@ -2205,31 +2250,30 @@ let close_apply acc env (apply : IR.apply) : Expr_with_acc.t = let before, after = cut (n - 1) t in h :: before, after in - let args_l = List.length args in - let arity_l = List.length arity in + let args_l = Flambda_arity.num_params apply.args_arity in + let arity_l = Flambda_arity.num_params non_unarized_arity in if args_l = arity_l then Exact args else if args_l < arity_l then - let _provided_arity, missing_arity = cut args_l arity in - Partial_app - { provided = args; - missing_arity = Flambda_arity.create missing_arity - } + let missing_arity = + Flambda_arity.partially_apply non_unarized_arity + ~num_non_unarized_params_provided:args_l + in + Partial_app { provided = args; missing_arity } else - let full, remaining = cut arity_l args in - let _, remaining_arity = cut arity_l args_arity in + let full, remaining = cut (List.length arity) args in + let remaining_arity = + Flambda_arity.partially_apply apply.args_arity + ~num_non_unarized_params_provided:arity_l + in Over_app { full; + provided_arity = non_unarized_arity; remaining; - remaining_arity = Flambda_arity.create remaining_arity + remaining_arity } in - let arity = - if is_tupled - then [Flambda_kind.With_subkind.block Tag.zero arity] - else arity - in split apply.args arity in match split_args with @@ -2249,7 +2293,7 @@ let close_apply acc env (apply : IR.apply) : Expr_with_acc.t = wrap_partial_application acc env apply.continuation apply approx ~provided ~missing_arity ~arity ~num_trailing_local_params ~contains_no_escaping_local_allocs - | Over_app { full; remaining; remaining_arity } -> + | Over_app { full; provided_arity; remaining; remaining_arity } -> let full_args_call apply_continuation ~region acc = let mode = if contains_no_escaping_local_allocs @@ -2259,10 +2303,12 @@ let close_apply acc env (apply : IR.apply) : Expr_with_acc.t = close_exact_or_unknown_apply acc env { apply with args = full; + args_arity = provided_arity; continuation = apply_continuation; mode; return_arity = - Flambda_arity.create [Flambda_kind.With_subkind.any_value] + Flambda_arity.create_singletons + [Flambda_kind.With_subkind.any_value] } (Some approx) ~replace_region:(Some region) in diff --git a/middle_end/flambda2/from_lambda/closure_conversion.mli b/middle_end/flambda2/from_lambda/closure_conversion.mli index d0a8937e8af..bf087060817 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.mli +++ b/middle_end/flambda2/from_lambda/closure_conversion.mli @@ -70,6 +70,15 @@ val close_switch : IR.switch -> Expr_with_acc.t +val close_raise : + Acc.t -> + Env.t -> + raise_kind:Lambda.raise_kind -> + arg:IR.simple -> + Lambda.scoped_location -> + IR.exn_continuation -> + Expr_with_acc.t + type 'a close_program_metadata = | Normal : [`Normal] close_program_metadata | Classic : diff --git a/middle_end/flambda2/from_lambda/closure_conversion_aux.ml b/middle_end/flambda2/from_lambda/closure_conversion_aux.ml index f83b17f87ae..bb7d7683639 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion_aux.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion_aux.ml @@ -64,7 +64,8 @@ module IR = struct probe : Lambda.probe; mode : Lambda.alloc_mode; region : Ident.t; - return_arity : Flambda_arity.t + args_arity : [`Complex] Flambda_arity.t; + return_arity : [`Complex] Flambda_arity.t } type switch = @@ -674,7 +675,9 @@ module Function_decls = struct function_slot : Function_slot.t; kind : Lambda.function_kind; params : (Ident.t * Flambda_kind.With_subkind.t) list; - return : Flambda_arity.t; + removed_params : Ident.Set.t; + params_arity : [`Complex] Flambda_arity.t; + return : [`Complex] Flambda_arity.t; return_continuation : Continuation.t; exn_continuation : IR.exn_continuation; my_region : Ident.t; @@ -688,11 +691,11 @@ module Function_decls = struct contains_no_escaping_local_allocs : bool } - let create ~let_rec_ident ~function_slot ~kind ~params ~return - ~return_continuation ~exn_continuation ~my_region ~body - ~(attr : Lambda.function_attribute) ~loc ~free_idents_of_body recursive - ~closure_alloc_mode ~num_trailing_local_params - ~contains_no_escaping_local_allocs = + let create ~let_rec_ident ~function_slot ~kind ~params ~params_arity + ~removed_params ~return ~return_continuation ~exn_continuation + ~my_region ~body ~(attr : Lambda.function_attribute) ~loc + ~free_idents_of_body recursive ~closure_alloc_mode + ~num_trailing_local_params ~contains_no_escaping_local_allocs = let let_rec_ident = match let_rec_ident with | None -> Ident.create_local "unnamed_function" @@ -702,6 +705,8 @@ module Function_decls = struct function_slot; kind; params; + params_arity; + removed_params; return; return_continuation; exn_continuation; @@ -724,6 +729,8 @@ module Function_decls = struct let params t = t.params + let params_arity t = t.params_arity + let return t = t.return let return_continuation t = t.return_continuation @@ -734,7 +741,7 @@ module Function_decls = struct let body t = t.body - let free_idents t = t.free_idents_of_body + let free_idents t = Ident.Set.diff t.free_idents_of_body t.removed_params let inline t = t.attr.inline @@ -940,7 +947,7 @@ module Let_with_acc = struct ~find_code_characteristics:(fun code_id -> let code = Code_id.Map.find code_id code_mapping in { cost_metrics = Code.cost_metrics code; - params_arity = Flambda_arity.cardinal (Code.params_arity code) + params_arity = Flambda_arity.num_params (Code.params_arity code) }) set_of_closures | Rec_info _ -> Cost_metrics.zero diff --git a/middle_end/flambda2/from_lambda/closure_conversion_aux.mli b/middle_end/flambda2/from_lambda/closure_conversion_aux.mli index 1d32232d514..bd9e3c06efa 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion_aux.mli +++ b/middle_end/flambda2/from_lambda/closure_conversion_aux.mli @@ -68,7 +68,8 @@ module IR : sig probe : Lambda.probe; mode : Lambda.alloc_mode; region : Ident.t; - return_arity : Flambda_arity.t + args_arity : [`Complex] Flambda_arity.t; + return_arity : [`Complex] Flambda_arity.t } type switch = @@ -77,6 +78,8 @@ module IR : sig failaction : (Continuation.t * trap_action option * simple list) option } + val print_simple : Format.formatter -> simple -> unit + val print_named : Format.formatter -> named -> unit end @@ -298,7 +301,9 @@ module Function_decls : sig function_slot:Function_slot.t -> kind:Lambda.function_kind -> params:(Ident.t * Flambda_kind.With_subkind.t) list -> - return:Flambda_arity.t -> + params_arity:[`Complex] Flambda_arity.t -> + removed_params:Ident.Set.t -> + return:[`Complex] Flambda_arity.t -> return_continuation:Continuation.t -> exn_continuation:IR.exn_continuation -> my_region:Ident.t -> @@ -320,7 +325,9 @@ module Function_decls : sig val params : t -> (Ident.t * Flambda_kind.With_subkind.t) list - val return : t -> Flambda_arity.t + val params_arity : t -> [`Complex] Flambda_arity.t + + val return : t -> [`Complex] Flambda_arity.t val return_continuation : t -> Continuation.t diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml index d42babe85ad..d8bd0097d95 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml @@ -17,6 +17,9 @@ (* "Use CPS". -- A. Kennedy, "Compiling with Continuations Continued", ICFP 2007. *) +let unboxed_product_debug () = + match Sys.getenv "DEBUG" with exception Not_found -> false | _ -> true + module L = Lambda module CC = Closure_conversion module P = Flambda_primitive @@ -44,14 +47,27 @@ module Env : sig val is_mutable : t -> Ident.t -> bool - val register_mutable_variable : t -> Ident.t -> Lambda.layout -> t * Ident.t + val register_mutable_variable : + t -> Ident.t -> Flambda_kind.With_subkind.t -> t * Ident.t val update_mutable_variable : t -> Ident.t -> t * Ident.t + val register_unboxed_product : + t -> + unboxed_product:Ident.t -> + before_unarization:[`Complex] Flambda_arity.Component_for_creation.t -> + fields:(Ident.t * Flambda_kind.With_subkind.t) list -> + t + + val get_unboxed_product_fields : + t -> + Ident.t -> + ([`Complex] Flambda_arity.Component_for_creation.t * Ident.t list) option + type add_continuation_result = private { body_env : t; handler_env : t; - extra_params : (Ident.t * Lambda.layout) list + extra_params : (Ident.t * Flambda_kind.With_subkind.t) list } val add_continuation : @@ -77,11 +93,10 @@ module Env : sig val extra_args_for_continuation : t -> Continuation.t -> Ident.t list val extra_args_for_continuation_with_kinds : - t -> Continuation.t -> (Ident.t * Lambda.layout) list - - val get_mutable_variable : t -> Ident.t -> Ident.t + t -> Continuation.t -> (Ident.t * Flambda_kind.With_subkind.t) list - val get_mutable_variable_with_kind : t -> Ident.t -> Ident.t * Lambda.layout + val get_mutable_variable_with_kind : + t -> Ident.t -> Ident.t * Flambda_kind.With_subkind.t (** About local allocation regions: @@ -186,8 +201,14 @@ end = struct type t = { current_unit : Compilation_unit.t; current_values_of_mutables_in_scope : - (Ident.t * Lambda.layout) Ident.Map.t; + (Ident.t * Flambda_kind.With_subkind.t) Ident.Map.t; mutables_needed_by_continuations : Ident.Set.t Continuation.Map.t; + unboxed_product_components_in_scope : + ([`Complex] Flambda_arity.Component_for_creation.t + * (Ident.t * Flambda_kind.With_subkind.t) array) + Ident.Map.t; + unboxed_product_components_needed_by_continuations : + Ident.Set.t Continuation.Map.t; try_stack : Continuation.t list; try_stack_at_handler : Continuation.t list Continuation.Map.t; static_exn_continuation : Continuation.t Numeric_types.Int.Map.t; @@ -203,9 +224,15 @@ end = struct Continuation.Map.of_list [return_continuation, Ident.Set.empty; exn_continuation, Ident.Set.empty] in + let unboxed_product_components_needed_by_continuations = + Continuation.Map.of_list + [return_continuation, Ident.Set.empty; exn_continuation, Ident.Set.empty] + in { current_unit; current_values_of_mutables_in_scope = Ident.Map.empty; mutables_needed_by_continuations; + unboxed_product_components_in_scope = Ident.Map.empty; + unboxed_product_components_needed_by_continuations; try_stack = []; try_stack_at_handler = Continuation.Map.empty; static_exn_continuation = Numeric_types.Int.Map.empty; @@ -245,10 +272,30 @@ end = struct let mutables_in_scope t = Ident.Map.keys t.current_values_of_mutables_in_scope + let register_unboxed_product t ~unboxed_product ~before_unarization ~fields = + if unboxed_product_debug () + then + Format.eprintf "register_unboxed_product %a: fields: %a\n%!" Ident.print + unboxed_product + (Format.pp_print_list ~pp_sep:Format.pp_print_space + (fun ppf (id, kind) -> + Format.fprintf ppf "%a :: %a" Ident.print id + Flambda_kind.With_subkind.print kind)) + fields; + { t with + unboxed_product_components_in_scope = + Ident.Map.add unboxed_product + (before_unarization, Array.of_list fields) + t.unboxed_product_components_in_scope + } + + let unboxed_product_components_in_scope t = + Ident.Map.keys t.unboxed_product_components_in_scope + type add_continuation_result = { body_env : t; handler_env : t; - extra_params : (Ident.t * Lambda.layout) list + extra_params : (Ident.t * Flambda_kind.With_subkind.t) list } let add_continuation t cont ~push_to_try_stack (recursive : Asttypes.rec_flag) @@ -261,11 +308,17 @@ end = struct Continuation.Map.add cont (mutables_in_scope t) t.mutables_needed_by_continuations in + let unboxed_product_components_needed_by_continuations = + Continuation.Map.add cont + (unboxed_product_components_in_scope t) + t.unboxed_product_components_needed_by_continuations + in let try_stack = if push_to_try_stack then cont :: t.try_stack else t.try_stack in { t with mutables_needed_by_continuations; + unboxed_product_components_needed_by_continuations; try_stack; region_stack_in_cont_scope } @@ -275,6 +328,15 @@ end = struct (fun mut_var (_outer_value, kind) -> Ident.rename mut_var, kind) t.current_values_of_mutables_in_scope in + let unboxed_product_components_in_scope = + Ident.Map.map + (fun (before_unarization, fields) -> + let fields = + Array.map (fun (field, layout) -> Ident.rename field, layout) fields + in + before_unarization, fields) + t.unboxed_product_components_in_scope + in let handler_env = let handler_env = match recursive with @@ -286,12 +348,24 @@ end = struct in { handler_env with current_values_of_mutables_in_scope; + unboxed_product_components_in_scope; region_stack_in_cont_scope } in + let extra_params_for_unboxed_products = + Ident.Map.data handler_env.unboxed_product_components_in_scope + |> List.map snd |> List.map Array.to_list |> List.concat + in let extra_params = Ident.Map.data handler_env.current_values_of_mutables_in_scope + @ extra_params_for_unboxed_products in + if unboxed_product_debug () + then + Format.eprintf "Adding continuation %a with extra params: %a\n%!" + Continuation.print cont + (Format.pp_print_list ~pp_sep:Format.pp_print_space Ident.print) + (List.map fst extra_params); { body_env; handler_env; extra_params } let add_static_exn_continuation t static_exn cont = @@ -343,18 +417,48 @@ end = struct | stack -> stack let extra_args_for_continuation_with_kinds t cont = - match Continuation.Map.find cont t.mutables_needed_by_continuations with - | exception Not_found -> - Misc.fatal_errorf "Unbound continuation %a" Continuation.print cont - | mutables -> - let mutables = Ident.Set.elements mutables in - List.map - (fun mut -> - match Ident.Map.find mut t.current_values_of_mutables_in_scope with - | exception Not_found -> - Misc.fatal_errorf "No current value for %a" Ident.print mut - | current_value, kind -> current_value, kind) - mutables + let for_mutables = + match Continuation.Map.find cont t.mutables_needed_by_continuations with + | exception Not_found -> + Misc.fatal_errorf "Unbound continuation %a" Continuation.print cont + | mutables -> + let mutables = Ident.Set.elements mutables in + List.map + (fun mut -> + match Ident.Map.find mut t.current_values_of_mutables_in_scope with + | exception Not_found -> + Misc.fatal_errorf "No current value for %a" Ident.print mut + | current_value, kind -> current_value, kind) + mutables + in + let for_unboxed_products = + match + Continuation.Map.find cont + t.unboxed_product_components_needed_by_continuations + with + | exception Not_found -> + Misc.fatal_errorf "Unbound continuation %a" Continuation.print cont + | unboxed_products_to_fields -> + let unboxed_products = Ident.Set.elements unboxed_products_to_fields in + List.concat_map + (fun unboxed_product -> + match + Ident.Map.find unboxed_product + t.unboxed_product_components_in_scope + with + | exception Not_found -> + Misc.fatal_errorf + "No field list registered for unboxed product %a" Ident.print + unboxed_product + | _, fields -> Array.to_list fields) + unboxed_products + in + if unboxed_product_debug () + then + Format.eprintf "Extra args for %a are: %a\n%!" Continuation.print cont + (Format.pp_print_list ~pp_sep:Format.pp_print_space Ident.print) + (List.map fst (for_mutables @ for_unboxed_products)); + for_mutables @ for_unboxed_products let extra_args_for_continuation t cont = List.map fst (extra_args_for_continuation_with_kinds t cont) @@ -365,7 +469,11 @@ end = struct Misc.fatal_errorf "Mutable variable %a not bound in env" Ident.print id | id, kind -> id, kind - let get_mutable_variable t id = fst (get_mutable_variable_with_kind t id) + let get_unboxed_product_fields t id = + match Ident.Map.find id t.unboxed_product_components_in_scope with + | exception Not_found -> None + | before_unarization, fields -> + Some (before_unarization, List.map fst (Array.to_list fields)) let entering_region t id ~continuation_closing_region ~continuation_after_closing_region = @@ -457,6 +565,18 @@ module Acc = Closure_conversion_aux.Acc type primitive_transform_result = | Primitive of L.primitive * L.lambda list * L.scoped_location | Transformed of L.lambda + | Unboxed_binding of + (Ident.t * Flambda_kind.With_subkind.t) option list * Env.t + (** [Unboxed_binding] enables a subset of the unboxed values arriving from + the defining expression to be bound. *) + +let must_be_singleton_simple simples = + match simples with + | [simple] -> simple + | [] | _ :: _ -> + Misc.fatal_errorf "Expected singleton Simple but got: %a" + (Format.pp_print_list ~pp_sep:Format.pp_print_space IR.print_simple) + simples let print_compact_location ppf (loc : Location.t) = if loc.loc_start.pos_fname = "//toplevel//" @@ -475,13 +595,9 @@ let name_for_function (func : Lambda.lfunction) = Format.asprintf "anon-fn[%a]" print_compact_location loc let extra_args_for_exn_continuation env exn_handler = - let more_extra_args = - Env.extra_args_for_continuation_with_kinds env exn_handler - in List.map - (fun (arg, kind) : (IR.simple * _) -> - Var arg, Flambda_kind.With_subkind.from_lambda kind) - more_extra_args + (fun (ident, kind) -> IR.Var ident, kind) + (Env.extra_args_for_continuation_with_kinds env exn_handler) let _print_stack ppf stack = Format.fprintf ppf "%a" @@ -599,7 +715,7 @@ let switch_for_if_then_else ~cond ~ifso ~ifnot ~kind = in L.Lswitch (cond, switch, Loc_unknown, kind) -let transform_primitive env (prim : L.primitive) args loc = +let transform_primitive env id (prim : L.primitive) args loc = match prim, args with | Psequor, [arg1; arg2] -> let const_true = Ident.create_local "const_true" in @@ -699,9 +815,120 @@ let transform_primitive env (prim : L.primitive) args loc = Primitive (L.Pccall desc, args, loc) else Misc.fatal_errorf - "Lambda_to_flambda.transform_primimive: Pbigarrayset with unknown \ + "Lambda_to_flambda.transform_primitive: Pbigarrayset with unknown \ layout and elements should only have dimensions between 1 and 3 \ (see translprim).") + | Pmake_unboxed_product layouts, args -> + (* CR mshinwell: should there be a case here for when args is a + singleton? *) + if List.compare_lengths layouts args <> 0 + then + Misc.fatal_errorf + "Pmake_unboxed_product layouts (%a) don't match arguments (%a)" + (Format.pp_print_list ~pp_sep:Format.pp_print_space Printlambda.layout) + layouts + (Format.pp_print_list ~pp_sep:Format.pp_print_space Printlambda.lambda) + args; + let arity_component = + Flambda_arity.Component_for_creation.Unboxed_product + (List.map Flambda_arity.Component_for_creation.from_lambda layouts) + in + let arity = Flambda_arity.create [arity_component] in + let fields = Flambda_arity.fresh_idents_unarized ~id arity in + let env = + Env.register_unboxed_product env ~unboxed_product:id + ~before_unarization:arity_component ~fields + in + if unboxed_product_debug () + then + Format.eprintf "Making unboxed product, bound to %a: num fields = %d\n%!" + Ident.print id (List.length fields); + let fields = List.map (fun ident_and_kind -> Some ident_and_kind) fields in + Unboxed_binding (fields, env) + | Punboxed_product_field (n, layouts), [_arg] -> + let layouts_array = Array.of_list layouts in + if n < 0 || n >= Array.length layouts_array + then Misc.fatal_errorf "Invalid field index %d for Punboxed_product_field" n; + let arity_component = + Flambda_arity.Component_for_creation.Unboxed_product + (List.map Flambda_arity.Component_for_creation.from_lambda layouts) + in + let arity = Flambda_arity.create [arity_component] in + if unboxed_product_debug () + then + Format.eprintf + "Punboxed_product_field bound to %a, product %a, field %d, arity %a:\n\ + %!" + Ident.print id Printlambda.lambda _arg n Flambda_arity.print arity; + let field_arity_component = + (* N.B. The arity of the field being projected, bound to [id], may in + itself be an unboxed product. *) + layouts_array.(n) |> Flambda_arity.Component_for_creation.from_lambda + in + let field_arity = Flambda_arity.create [field_arity_component] in + let ids_all_fields_with_kinds = + Flambda_arity.fresh_idents_unarized arity ~id + in + let num_fields_prior_to_projected_fields = + Misc.Stdlib.List.split_at n layouts + |> fst + |> List.map Flambda_arity.Component_for_creation.from_lambda + |> Flambda_arity.create |> Flambda_arity.cardinal_unarized + in + if unboxed_product_debug () + then + Format.eprintf "num_fields_prior_to_projected_fields %d\n%!" + num_fields_prior_to_projected_fields; + let num_projected_fields = Flambda_arity.cardinal_unarized field_arity in + let ids_projected_fields = + Array.sub + (Array.of_list ids_all_fields_with_kinds) + num_fields_prior_to_projected_fields num_projected_fields + |> Array.to_list + (* CR mshinwell: try to keep this as an array? *) + in + let env = + if num_projected_fields <> 1 + then + (* If the field being projected is an unboxed product, we must ensure + any occurrences of [id] get expanded to the individual fields, just + like we do in the [Pmake_unboxed_product] case above. *) + Env.register_unboxed_product env ~unboxed_product:id + ~before_unarization:field_arity_component ~fields:ids_projected_fields + else env + in + if unboxed_product_debug () + then + Format.eprintf + "Unboxed projection: emitting binding of %d ids, num projected fields %d\n\ + %!" + (List.length ids_all_fields_with_kinds) + (List.length ids_projected_fields); + let field_mask = + List.mapi + (fun cur_field (field, kind) -> + if cur_field < num_fields_prior_to_projected_fields + || cur_field + >= num_fields_prior_to_projected_fields + num_projected_fields + then None + else + match ids_projected_fields with + | [(_, kind)] -> + (* If no splitting is occurring, we must cause [id] to be bound, + being the original bound variable from the enclosing [Llet]. *) + Some (id, kind) + | [] | _ :: _ -> + (* In all other cases we cause one of the variables representing + the individual fields of the unboxed product to be bound. *) + Some (field, kind)) + ids_all_fields_with_kinds + in + Unboxed_binding (field_mask, env) + | Punboxed_product_field _, (([] | _ :: _) as args) -> + Misc.fatal_errorf + "Punboxed_product_field only takes one argument, but found: %a" + (Format.pp_print_list ~pp_sep:Format.pp_print_space Printlambda.lambda) + args | _, _ -> Primitive (prim, args, loc) [@@ocaml.warning "-fragile-match"] @@ -790,17 +1017,54 @@ let let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler let { Env.body_env; handler_env; extra_params } = Env.add_continuation env cont ~push_to_try_stack:is_exn_handler Nonrecursive in - let params = - List.map - (fun (id, visible, kind) -> - id, visible, Flambda_kind.With_subkind.from_lambda kind) - params + let orig_params = params in + let handler_env, params_rev = + List.fold_left + (fun (handler_env, params_rev) (id, visible, layout) -> + let arity_component = + Flambda_arity.Component_for_creation.from_lambda layout + in + match arity_component with + | Singleton kind -> + let param = id, visible, kind in + handler_env, param :: params_rev + | Unboxed_product _ -> + let arity = Flambda_arity.create [arity_component] in + let fields = + List.mapi + (fun n kind -> + let field = + Ident.create_local + (Printf.sprintf "%s_unboxed%d" (Ident.unique_name id) n) + in + field, kind) + (Flambda_arity.unarize arity) + in + let handler_env = + Env.register_unboxed_product handler_env ~unboxed_product:id + ~before_unarization:arity_component ~fields + in + let new_params_rev = + List.map (fun (id, kind) -> id, IR.Not_user_visible, kind) fields + |> List.rev + in + handler_env, new_params_rev @ params_rev) + (handler_env, []) params in + let params = List.rev params_rev in + if List.compare_lengths params orig_params <> 0 + then + if unboxed_product_debug () + then + Format.eprintf + "Continuation %a has unboxed arities: orig_params %a, params %a\n%!" + Continuation.print cont + (Format.pp_print_list ~pp_sep:Format.pp_print_space Ident.print) + (List.map (fun (id, _, _) -> id) orig_params) + (Format.pp_print_list ~pp_sep:Format.pp_print_space Ident.print) + (List.map (fun (id, _, _) -> id) params); let extra_params = - List.map - (fun (id, kind) -> - id, IR.User_visible, Flambda_kind.With_subkind.from_lambda kind) - extra_params + List.map (fun (id, kind) -> id, IR.User_visible, kind) extra_params in let handler acc ccenv = handler acc handler_env ccenv in let body acc ccenv = body acc body_env ccenv cont in @@ -872,9 +1136,16 @@ let wrap_return_continuation acc env ccenv (apply : IR.apply) = | [] -> CC.close_apply acc ccenv { apply with continuation; region } | _ :: _ -> let wrapper_cont = Continuation.create () in - let return_value = Ident.create_local "return_val" in + let return_kinds = Flambda_arity.unarize apply.return_arity in + let return_value_components = + List.mapi + (fun i _ -> Ident.create_local (Printf.sprintf "return_val%d" i)) + return_kinds + in let args = - List.map (fun var : IR.simple -> Var var) (return_value :: extra_args) + List.map + (fun var : IR.simple -> Var var) + (return_value_components @ extra_args) in let dbg = Debuginfo.none in let handler acc ccenv = @@ -884,20 +1155,14 @@ let wrap_return_continuation acc env ccenv (apply : IR.apply) = CC.close_apply acc ccenv { apply with continuation = wrapper_cont; region } in - let return_arity = - match Flambda_arity.to_list apply.return_arity with - | [return_kind] -> return_kind - | _ :: _ -> - Misc.fatal_errorf - "Multiple return values for application of %a not supported yet" - Ident.print apply.func - | [] -> - Misc.fatal_errorf "Nullary return arity for application of %a" - Ident.print apply.func + let params = + List.map2 + (fun return_value_component kind -> + return_value_component, IR.Not_user_visible, kind) + return_value_components return_kinds in CC.close_let_cont acc ccenv ~name:wrapper_cont ~is_exn_handler:false - ~params:[return_value, Not_user_visible, return_arity] - ~recursive:Nonrecursive ~body ~handler + ~params ~recursive:Nonrecursive ~body ~handler in restore_continuation_context acc env ccenv apply.continuation ~close_early body @@ -982,118 +1247,62 @@ let primitive_can_raise (prim : Lambda.primitive) = | Pbigstring_set_64 true | Pctconst _ | Pbswap16 | Pbbswap _ | Pint_as_pointer | Popaque _ | Pprobe_is_enabled _ | Pobj_dup | Pobj_magic _ | Pbox_float _ | Punbox_float - | Punbox_int _ | Pbox_int _ -> + | Punbox_int _ | Pbox_int _ | Pmake_unboxed_product _ + | Punboxed_product_field _ -> false -let primitive_result_kind (prim : Lambda.primitive) : - Flambda_kind.With_subkind.t = - match prim with - | Pccall { prim_native_repr_res = _, Untagged_int; _ } -> - Flambda_kind.With_subkind.tagged_immediate - | Pccall { prim_native_repr_res = _, Unboxed_float; _ } - | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ - | Pmulfloat _ | Pdivfloat _ | Pfloatfield _ - | Parrayrefs Pfloatarray - | Parrayrefu Pfloatarray - | Pbigarrayref (_, _, (Pbigarray_float32 | Pbigarray_float64), _) -> - Flambda_kind.With_subkind.boxed_float - | Pccall { prim_native_repr_res = _, Unboxed_integer Pnativeint; _ } - | Pbigarrayref (_, _, Pbigarray_native_int, _) -> - Flambda_kind.With_subkind.boxed_nativeint - | Pccall { prim_native_repr_res = _, Unboxed_integer Pint32; _ } - | Pstring_load_32 _ | Pbytes_load_32 _ | Pbigstring_load_32 _ - | Pbigarrayref (_, _, Pbigarray_int32, _) -> - Flambda_kind.With_subkind.boxed_int32 - | Pccall { prim_native_repr_res = _, Unboxed_integer Pint64; _ } - | Pstring_load_64 _ | Pbytes_load_64 _ | Pbigstring_load_64 _ - | Pbigarrayref (_, _, Pbigarray_int64, _) -> - Flambda_kind.With_subkind.boxed_int64 - | Pnegint | Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint | Plslint - | Plsrint | Pasrint | Pmodint _ | Pdivint _ | Pignore | Psequand | Psequor - | Pnot | Pbytesrefs | Pstringrefs | Pbytessets | Pstring_load_16 _ - | Pbytes_load_16 _ | Pbigstring_load_16 _ | Pbytes_set_16 _ | Pbytes_set_32 _ - | Pbytes_set_64 _ | Pbigstring_set_16 _ | Pbigstring_set_32 _ - | Pbigstring_set_64 _ | Pintcomp _ | Pcompare_ints | Pcompare_floats - | Pcompare_bints _ | Pintoffloat | Pfloatcomp _ | Parraysets _ - | Pbigarrayset _ | Psetfield _ | Psetfield_computed _ | Psetfloatfield _ - | Pstringlength | Pstringrefu | Pbyteslength | Pbytesrefu | Pbytessetu - | Parraylength _ | Parraysetu _ | Pisint _ | Pbintcomp _ | Pintofbint _ - | Pisout - | Parrayrefs Pintarray - | Parrayrefu Pintarray - | Pprobe_is_enabled _ | Pctconst _ | Pbswap16 - | Pbigarrayref - ( _, - _, - ( Pbigarray_sint8 | Pbigarray_uint8 | Pbigarray_sint16 - | Pbigarray_uint16 | Pbigarray_caml_int ), - _ ) -> - Flambda_kind.With_subkind.tagged_immediate - | Pdivbint { size = bi; _ } - | Pmodbint { size = bi; _ } - | Pandbint (bi, _) - | Porbint (bi, _) - | Pxorbint (bi, _) - | Plslbint (bi, _) - | Plsrbint (bi, _) - | Pasrbint (bi, _) - | Pnegbint (bi, _) - | Paddbint (bi, _) - | Psubbint (bi, _) - | Pmulbint (bi, _) - | Pbintofint (bi, _) - | Pcvtbint (_, bi, _) - | Pbbswap (bi, _) - | Pbox_int (bi, _) -> ( - match bi with - | Pint32 -> Flambda_kind.With_subkind.boxed_int32 - | Pint64 -> Flambda_kind.With_subkind.boxed_int64 - | Pnativeint -> Flambda_kind.With_subkind.boxed_nativeint) - | Popaque layout | Pobj_magic layout -> - Flambda_kind.With_subkind.from_lambda layout - | Praise _ -> - (* CR ncourant: this should be bottom, but we don't have it *) - Flambda_kind.With_subkind.any_value - | Pccall { prim_native_repr_res = _, Same_as_ocaml_repr; _ } - | Parrayrefs (Pgenarray | Paddrarray) - | Parrayrefu (Pgenarray | Paddrarray) - | Pbytes_to_string | Pbytes_of_string | Parray_of_iarray | Parray_to_iarray - | Pgetglobal _ | Psetglobal _ | Pgetpredef _ | Pmakeblock _ - | Pmakefloatblock _ | Pfield _ | Pfield_computed _ | Pduprecord _ - | Poffsetint _ | Poffsetref _ | Pmakearray _ | Pduparray _ | Pbigarraydim _ - | Pbigarrayref - (_, _, (Pbigarray_complex32 | Pbigarray_complex64 | Pbigarray_unknown), _) - | Pint_as_pointer | Pobj_dup -> - Flambda_kind.With_subkind.any_value - | Pbox_float _ -> Flambda_kind.With_subkind.boxed_float - | Punbox_float -> Flambda_kind.With_subkind.naked_float - | Punbox_int bi -> ( - match bi with - | Pint32 -> Flambda_kind.With_subkind.naked_int32 - | Pint64 -> Flambda_kind.With_subkind.naked_int64 - | Pnativeint -> Flambda_kind.With_subkind.naked_nativeint) +type non_tail_continuation = + Acc.t -> + Env.t -> + CCenv.t -> + IR.simple list -> + [`Complex] Flambda_arity.Component_for_creation.t -> + Expr_with_acc.t + +type non_tail_list_continuation = + Acc.t -> + Env.t -> + CCenv.t -> + IR.simple list -> + [`Complex] Flambda_arity.Component_for_creation.t list -> + Expr_with_acc.t type cps_continuation = | Tail of Continuation.t - | Non_tail of (Acc.t -> Env.t -> CCenv.t -> IR.simple -> Expr_with_acc.t) + | Non_tail of non_tail_continuation -let apply_cps_cont_simple k ?(dbg = Debuginfo.none) acc env ccenv simple = +let apply_cps_cont_simple k ?(dbg = Debuginfo.none) acc env ccenv simples + (arity_component : [`Complex] Flambda_arity.Component_for_creation.t) = match k with - | Tail k -> apply_cont_with_extra_args acc env ccenv ~dbg k None [simple] - | Non_tail k -> k acc env ccenv simple + | Tail k -> apply_cont_with_extra_args acc env ccenv ~dbg k None simples + | Non_tail k -> k acc env ccenv simples arity_component -let apply_cps_cont k ?dbg acc env ccenv id = - apply_cps_cont_simple k ?dbg acc env ccenv (IR.Var id) +let apply_cps_cont k ?dbg acc env ccenv id + (arity_component : [`Complex] Flambda_arity.Component_for_creation.t) = + apply_cps_cont_simple k ?dbg acc env ccenv [IR.Var id] arity_component -let maybe_insert_let_cont result_var_name kind k acc env ccenv body = +let maybe_insert_let_cont result_var_name layout k acc env ccenv body = match k with | Tail k -> body acc env ccenv k | Non_tail k -> - let result_var = Ident.create_local result_var_name in - let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler:false - ~params:[result_var, IR.Not_user_visible, kind] - ~handler:(fun acc env ccenv -> k acc env ccenv (IR.Var result_var)) - ~body + let arity_component = + Flambda_arity.Component_for_creation.from_lambda layout + in + let arity = Flambda_arity.create [arity_component] in + if Flambda_arity.cardinal_unarized arity < 1 + then + let_cont_nonrecursive_with_extra_params acc env ccenv + ~is_exn_handler:false ~params:[] + ~handler:(fun acc env ccenv -> k acc env ccenv [] arity_component) + ~body + else + let result_var = Ident.create_local result_var_name in + let_cont_nonrecursive_with_extra_params acc env ccenv + ~is_exn_handler:false + ~params:[result_var, IR.Not_user_visible, layout] + ~handler:(fun acc env ccenv -> + k acc env ccenv [IR.Var result_var] arity_component) + ~body let name_if_not_var acc ccenv name simple kind body = match simple with @@ -1106,13 +1315,42 @@ let name_if_not_var acc ccenv name simple kind body = let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) (k_exn : Continuation.t) : Expr_with_acc.t = match lam with - | Lvar id -> + | Lvar id -> ( assert (not (Env.is_mutable env id)); - apply_cps_cont k acc env ccenv id + if unboxed_product_debug () + then + Format.eprintf "checking for unboxed product fields of %a\n%!" Ident.print + id; + match Env.get_unboxed_product_fields env id with + | None -> + if unboxed_product_debug () then Format.eprintf "...no unboxed fields\n%!"; + let kind = + match CCenv.find_simple_to_substitute_exn ccenv id with + | exception Not_found -> snd (CCenv.find_var ccenv id) + | _, kind -> kind + in + let arity_component = + Flambda_arity.Component_for_creation.Singleton kind + in + apply_cps_cont k acc env ccenv id arity_component + | Some (before_unarization, fields) -> + if unboxed_product_debug () + then + Format.eprintf "...got unboxed fields: (%a)\n%!" + (Format.pp_print_list ~pp_sep:Format.pp_print_space Ident.print) + fields; + let fields = List.map (fun id -> IR.Var id) fields in + apply_cps_cont_simple k acc env ccenv fields before_unarization) | Lmutvar id -> - let return_id = Env.get_mutable_variable env id in + (* CR mshinwell: note: mutable variables of non-singleton layouts are not + supported *) + let return_id, kind = Env.get_mutable_variable_with_kind env id in apply_cps_cont k acc env ccenv return_id - | Lconst const -> apply_cps_cont_simple k acc env ccenv (IR.Const const) + (Flambda_arity.Component_for_creation.Singleton kind) + | Lconst const -> + apply_cps_cont_simple k acc env ccenv [IR.Const const] + (* CR mshinwell: improve layout here *) + (Singleton Flambda_kind.With_subkind.any_value) | Lapply { ap_func; ap_args; @@ -1137,7 +1375,10 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let func = cps_function env ~fid:id ~recursive:(Non_recursive : Recursive.t) func in - let body acc ccenv = apply_cps_cont k ~dbg acc env ccenv id in + let body acc ccenv = + apply_cps_cont k ~dbg acc env ccenv id + (Singleton Flambda_kind.With_subkind.any_value) + in CC.close_let_rec acc ccenv ~function_declarations:[func] ~body ~current_region:(Env.current_region env) | Lmutlet (value_kind, id, defining_expr, body) -> @@ -1147,7 +1388,8 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) ~body:(fun acc env ccenv after_defining_expr -> cps_tail acc env ccenv defining_expr after_defining_expr k_exn) ~handler:(fun acc env ccenv -> - let env, new_id = Env.register_mutable_variable env id value_kind in + let kind = Flambda_kind.With_subkind.from_lambda value_kind in + let env, new_id = Env.register_mutable_variable env id kind in let body acc ccenv = cps acc env ccenv body k k_exn in CC.close_let acc ccenv new_id User_visible (Flambda_kind.With_subkind.from_lambda value_kind) @@ -1176,7 +1418,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) id, Lprim (prim, args, loc), body ) -> ( - match transform_primitive env prim args loc with + if unboxed_product_debug () + then Format.eprintf "Handling let-binding: %a\n%!" Printlambda.lambda lam; + match transform_primitive env id prim args loc with | Primitive (prim, args, loc) -> (* This case avoids extraneous continuations. *) let exn_continuation : IR.exn_continuation option = @@ -1189,7 +1433,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) else None in cps_non_tail_list acc env ccenv args - (fun acc env ccenv args -> + (fun acc env ccenv args _arity -> let body acc ccenv = cps acc env ccenv body k k_exn in let region = Env.current_region env in CC.close_let acc ccenv id User_visible @@ -1197,6 +1441,45 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) (Prim { prim; args; loc; exn_continuation; region }) ~body) k_exn + | Unboxed_binding (ids_with_kinds, env) -> + cps_non_tail_list acc env ccenv args + (fun acc env ccenv (args : IR.simple list) _arity -> + if unboxed_product_debug () + then + Format.eprintf "Unboxed_binding: ids_with_kinds=(%a) args=(%a)\n%!" + (Format.pp_print_list ~pp_sep:Format.pp_print_space + (Misc.Stdlib.Option.print (fun ppf (id, kind) -> + Format.fprintf ppf "%a :: %a" Ident.print id + Flambda_kind.With_subkind.print kind))) + ids_with_kinds + (Format.pp_print_list ~pp_sep:Format.pp_print_space + IR.print_simple) + args; + let body acc ccenv = cps acc env ccenv body k k_exn in + if List.compare_lengths ids_with_kinds args <> 0 + then + Misc.fatal_errorf + "ids_with_kinds (%a) doesn't match args (%a) for:@ %a" + (Format.pp_print_list ~pp_sep:Format.pp_print_space + (Misc.Stdlib.Option.print (fun ppf (id, kind) -> + Format.fprintf ppf "%a :: %a" Ident.print id + Flambda_kind.With_subkind.print kind))) + ids_with_kinds + (Format.pp_print_list ~pp_sep:Format.pp_print_space + IR.print_simple) + args Printlambda.lambda lam; + let builder = + List.fold_left2 + (fun body id_and_kind_opt arg acc ccenv -> + match id_and_kind_opt with + | None -> body acc ccenv + | Some (id, kind) -> + CC.close_let acc ccenv id Not_user_visible kind (Simple arg) + ~body) + body ids_with_kinds args + in + builder acc ccenv) + k_exn | Transformed lam -> cps acc env ccenv (L.Llet (let_kind, layout, id, lam, body)) k k_exn) | Llet @@ -1212,7 +1495,8 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) Misc.fatal_errorf "Lassign on non-mutable variable %a" Ident.print being_assigned; cps_non_tail_simple acc env ccenv new_value - (fun acc env ccenv new_value -> + (fun acc env ccenv new_value _arity -> + let new_value = must_be_singleton_simple new_value in let env, new_id = Env.update_mutable_variable env being_assigned in let body acc ccenv = let body acc ccenv = cps acc env ccenv body k k_exn in @@ -1223,9 +1507,8 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let value_kind = snd (Env.get_mutable_variable_with_kind env being_assigned) in - CC.close_let acc ccenv new_id User_visible - (Flambda_kind.With_subkind.from_lambda value_kind) - (Simple new_value) ~body) + CC.close_let acc ccenv new_id User_visible value_kind (Simple new_value) + ~body) k_exn | Llet ((Strict | Alias | StrictOpt), layout, id, defining_expr, body) -> let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler:false @@ -1256,30 +1539,35 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) ~current_region:(Env.current_region env) | Dissected lam -> cps acc env ccenv lam k k_exn) | Lprim (prim, args, loc) -> ( - match transform_primitive env prim args loc with - | Primitive (prim, args, loc) -> - let name = Printlambda.name_of_primitive prim in - let result_var = Ident.create_local name in - let exn_continuation : IR.exn_continuation option = - if primitive_can_raise prim - then - Some - { exn_handler = k_exn; - extra_args = extra_args_for_exn_continuation env k_exn - } - else None - in - let current_region = Env.current_region env in - let dbg = Debuginfo.from_location loc in - cps_non_tail_list acc env ccenv args - (fun acc env ccenv args -> - let body acc ccenv = apply_cps_cont ~dbg k acc env ccenv result_var in - CC.close_let acc ccenv result_var Not_user_visible - (primitive_result_kind prim) - (Prim { prim; args; loc; exn_continuation; region = current_region }) - ~body) - k_exn - | Transformed lam -> cps acc env ccenv lam k k_exn) + match[@ocaml.warning "-fragile-match"] prim with + | Praise raise_kind -> ( + match args with + | [_] -> + cps_non_tail_list acc env ccenv args + (fun acc _env ccenv args _arity -> + let exn_continuation : IR.exn_continuation = + { exn_handler = k_exn; + extra_args = extra_args_for_exn_continuation env k_exn + } + in + CC.close_raise acc ccenv ~raise_kind ~arg:(List.hd args) loc + exn_continuation) + k_exn + | [] | _ :: _ -> + Misc.fatal_errorf "Wrong number of arguments for Lraise: %a" + Printlambda.primitive prim) + | _ -> + let id = Ident.create_local "prim" in + let result_layout = L.primitive_result_layout prim in + (match result_layout with + | Pvalue _ | Punboxed_float | Punboxed_int _ | Punboxed_product _ -> () + | Ptop | Pbottom -> + Misc.fatal_errorf "Invalid result layout %a for primitive %a" + Printlambda.layout result_layout Printlambda.primitive prim); + (* CR mshinwell: find a way of making these lets non-user-visible *) + cps acc env ccenv + (L.Llet (Strict, result_layout, id, lam, L.Lvar id)) + k k_exn) | Lswitch (scrutinee, switch, loc, kind) -> maybe_insert_let_cont "switch_result" kind k acc env ccenv (fun acc env ccenv k -> @@ -1293,7 +1581,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) | Lstaticraise (static_exn, args) -> let continuation = Env.get_static_exn_continuation env static_exn in cps_non_tail_list acc env ccenv args - (fun acc env ccenv args -> + (fun acc env ccenv args _arity -> let extra_args = List.map (fun var : IR.simple -> Var var) @@ -1314,10 +1602,18 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) else Nonrecursive in let params = - List.map - (fun (arg, kind) -> - arg, IR.User_visible, Flambda_kind.With_subkind.from_lambda kind) - (args @ extra_params) + let args = + List.map + (fun (arg, kind) -> + arg, IR.User_visible, Flambda_kind.With_subkind.from_lambda kind) + args + in + let extra_params = + List.map + (fun (extra_param, kind) -> extra_param, IR.User_visible, kind) + extra_params + in + args @ extra_params in let handler acc ccenv = let ccenv = CCenv.set_not_at_toplevel ccenv in @@ -1328,12 +1624,13 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) ~params ~recursive ~body ~handler) | Lsend (meth_kind, meth, obj, args, pos, mode, loc, layout) -> cps_non_tail_simple acc env ccenv obj - (fun acc env ccenv obj -> + (fun acc env ccenv obj _obj_arity -> + let obj = must_be_singleton_simple obj in cps_non_tail_var "meth" acc env ccenv meth Flambda_kind.With_subkind.any_value - (fun acc env ccenv meth -> + (fun acc env ccenv meth _meth_arity -> cps_non_tail_list acc env ccenv args - (fun acc env ccenv args -> + (fun acc env ccenv args args_arity -> maybe_insert_let_cont "send_result" layout k acc env ccenv (fun acc env ccenv k -> let exn_continuation : IR.exn_continuation = @@ -1353,8 +1650,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) probe = None; mode; region = Env.current_region env; + args_arity = Flambda_arity.create args_arity; return_arity = - Flambda_arity.create + Flambda_arity.create_singletons [Flambda_kind.With_subkind.from_lambda layout] } in @@ -1424,7 +1722,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let lam = switch_for_if_then_else ~cond ~ifso ~ifnot ~kind in cps acc env ccenv lam k k_exn | Lsequence (lam1, lam2) -> - let k acc env ccenv _value = cps acc env ccenv lam2 k k_exn in + let k acc env ccenv _value _arity = cps acc env ccenv lam2 k k_exn in cps_non_tail_simple acc env ccenv lam1 k k_exn | Lwhile { wh_cond = cond; wh_body = body } -> (* CR-someday mshinwell: make use of wh_cond_region / wh_body_region? *) @@ -1445,17 +1743,18 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) Misc.fatal_errorf "Lassign on non-mutable variable %a" Ident.print being_assigned; cps_non_tail_simple acc env ccenv new_value - (fun acc env ccenv new_value -> + (fun acc env ccenv new_value _arity -> + let new_value = must_be_singleton_simple new_value in let env, new_id = Env.update_mutable_variable env being_assigned in let body acc ccenv = - apply_cps_cont_simple k acc env ccenv (Const L.const_unit) + apply_cps_cont_simple k acc env ccenv [Const L.const_unit] + (Singleton Flambda_kind.With_subkind.tagged_immediate) in let _, value_kind = Env.get_mutable_variable_with_kind env being_assigned in - CC.close_let acc ccenv new_id User_visible - (Flambda_kind.With_subkind.from_lambda value_kind) - (Simple new_value) ~body) + CC.close_let acc ccenv new_id User_visible value_kind (Simple new_value) + ~body) k_exn | Levent (body, _event) -> cps acc env ccenv body k k_exn | Lifused _ -> @@ -1527,24 +1826,48 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) apply_cont_with_extra_args acc env ccenv ~dbg k None [IR.Var wrap_return])))) -and cps_non_tail_simple acc env ccenv lam k k_exn = +and cps_non_tail_simple : + Acc.t -> + Env.t -> + CCenv.t -> + Lambda.lambda -> + non_tail_continuation -> + Continuation.t -> + Expr_with_acc.t = + fun acc env ccenv lam (k : non_tail_continuation) k_exn -> cps acc env ccenv lam (Non_tail k) k_exn -and cps_non_tail_var name acc env ccenv lam kind k k_exn = +and cps_non_tail_var : + string -> + Acc.t -> + Env.t -> + CCenv.t -> + Lambda.lambda -> + Flambda_kind.With_subkind.t -> + (Acc.t -> + Env.t -> + CCenv.t -> + Ident.t -> + [`Complex] Flambda_arity.Component_for_creation.t -> + Expr_with_acc.t) -> + Continuation.t -> + Expr_with_acc.t = + fun name acc env ccenv lam kind k k_exn -> cps_non_tail_simple acc env ccenv lam - (fun acc env ccenv simple -> + (fun acc env ccenv simple arity -> + let simple = must_be_singleton_simple simple in name_if_not_var acc ccenv name simple kind (fun var acc ccenv -> - k acc env ccenv var)) + k acc env ccenv var arity)) k_exn and cps_tail_apply acc env ccenv ap_func ap_args ap_region_close ap_mode ap_loc ap_inlined ap_probe ap_return (k : Continuation.t) (k_exn : Continuation.t) : Expr_with_acc.t = cps_non_tail_list acc env ccenv ap_args - (fun acc env ccenv args -> + (fun acc env ccenv args args_arity -> cps_non_tail_var "func" acc env ccenv ap_func Flambda_kind.With_subkind.any_value - (fun acc env ccenv func -> + (fun acc env ccenv func _func_arity -> let exn_continuation : IR.exn_continuation = { exn_handler = k_exn; extra_args = extra_args_for_exn_continuation env k_exn @@ -1562,9 +1885,10 @@ and cps_tail_apply acc env ccenv ap_func ap_args ap_region_close ap_mode ap_loc probe = ap_probe; mode = ap_mode; region = Env.current_region env; + args_arity = Flambda_arity.create args_arity; return_arity = Flambda_arity.create - [Flambda_kind.With_subkind.from_lambda ap_return] + [Flambda_arity.Component_for_creation.from_lambda ap_return] } in wrap_return_continuation acc env ccenv apply) @@ -1575,23 +1899,33 @@ and cps_tail acc env ccenv (lam : L.lambda) (k : Continuation.t) (k_exn : Continuation.t) : Expr_with_acc.t = cps acc env ccenv lam (Tail k) k_exn -and cps_non_tail_list acc env ccenv lams k k_exn = +and cps_non_tail_list : + Acc.t -> + Env.t -> + CCenv.t -> + Lambda.lambda list -> + non_tail_list_continuation -> + Continuation.t -> + Expr_with_acc.t = + fun acc env ccenv lams (k : non_tail_list_continuation) k_exn -> let lams = List.rev lams in (* Always evaluate right-to-left. *) cps_non_tail_list_core acc env ccenv lams - (fun acc env ccenv ids -> k acc env ccenv (List.rev ids)) + (fun acc env ccenv ids + (arity : [`Complex] Flambda_arity.Component_for_creation.t list) -> + k acc env ccenv (List.rev ids) (List.rev arity)) k_exn and cps_non_tail_list_core acc env ccenv (lams : L.lambda list) - (k : Acc.t -> Env.t -> CCenv.t -> IR.simple list -> Expr_with_acc.t) - (k_exn : Continuation.t) = + (k : non_tail_list_continuation) (k_exn : Continuation.t) = match lams with - | [] -> k acc env ccenv [] + | [] -> k acc env ccenv [] [] | lam :: lams -> cps_non_tail_simple acc env ccenv lam - (fun acc env ccenv simple -> + (fun acc env ccenv simples arity -> cps_non_tail_list_core acc env ccenv lams - (fun acc env ccenv simples -> k acc env ccenv (simple :: simples)) + (fun acc env ccenv simples' arity' -> + k acc env ccenv (List.rev simples @ simples') (arity :: arity')) k_exn) k_exn @@ -1690,23 +2024,79 @@ and cps_function env ~fid ~(recursive : Recursive.t) ?precomputed_free_idents (Compilation_unit.get_current_exn ()) ~name:(Ident.name fid) Flambda_kind.With_subkind.any_value in + let params_arity = Flambda_arity.from_lambda_list (List.map snd params) in + let unarized_per_param = Flambda_arity.unarize_per_parameter params_arity in + assert (List.compare_lengths params unarized_per_param = 0); + let unboxed_products = ref Ident.Map.empty in + let params = + List.concat_map + (fun ((param, layout), kinds) -> + match kinds with + | [] -> [] + | [kind] -> [param, kind] + | _ :: _ -> + if unboxed_product_debug () + then + Format.eprintf + "splitting unboxed product for function parameter %a\n%!" + Ident.print param; + let fields = + List.mapi + (fun n kind -> + let ident = + Ident.create_local + (Printf.sprintf "%s_unboxed%d" (Ident.unique_name param) n) + in + ident, kind) + kinds + in + let before_unarization = + Flambda_arity.Component_for_creation.from_lambda layout + in + unboxed_products + := Ident.Map.add param + (before_unarization, fields) + !unboxed_products; + fields) + (List.combine params unarized_per_param) + in + if unboxed_product_debug () + then + if List.compare_lengths params unarized_per_param <> 0 + then + Format.eprintf "flattened param list for %a:@ %a\n%!" Ident.print fid + (Format.pp_print_list (fun ppf (id, kind) -> + Format.fprintf ppf "%a :: %a" Ident.print id + Flambda_kind.With_subkind.print kind)) + params; + let unboxed_products = !unboxed_products in + let removed_params = Ident.Map.keys unboxed_products in + let return = + Flambda_arity.create + [Flambda_arity.Component_for_creation.from_lambda return] + in let body acc ccenv = let ccenv = CCenv.set_path_to_root ccenv loc in let ccenv = CCenv.set_not_at_toplevel ccenv in + let new_env = + Ident.Map.fold + (fun unboxed_product (before_unarization, fields) new_env -> + if unboxed_product_debug () + then + Format.eprintf + "registering unboxed product for function parameter %a\n%!" + Ident.print unboxed_product; + Env.register_unboxed_product new_env ~unboxed_product + ~before_unarization ~fields) + unboxed_products new_env + in cps_tail acc new_env ccenv body body_cont body_exn_cont in - let params = - List.map - (fun (param, kind) -> param, Flambda_kind.With_subkind.from_lambda kind) - params - in - let return = - Flambda_arity.create [Flambda_kind.With_subkind.from_lambda return] - in Function_decl.create ~let_rec_ident:(Some fid) ~function_slot ~kind ~params - ~return ~return_continuation:body_cont ~exn_continuation ~my_region ~body - ~attr ~loc ~free_idents_of_body recursive ~closure_alloc_mode:mode - ~num_trailing_local_params ~contains_no_escaping_local_allocs:region + ~params_arity ~removed_params ~return ~return_continuation:body_cont + ~exn_continuation ~my_region ~body ~attr ~loc ~free_idents_of_body recursive + ~closure_alloc_mode:mode ~num_trailing_local_params + ~contains_no_escaping_local_allocs:region and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg ~scrutinee (k : Continuation.t) (k_exn : Continuation.t) : Expr_with_acc.t = @@ -1779,7 +2169,7 @@ and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg in cps_non_tail_var "scrutinee" acc env ccenv scrutinee Flambda_kind.With_subkind.any_value - (fun acc env ccenv scrutinee -> + (fun acc env ccenv scrutinee _arity -> let ccenv = CCenv.set_not_at_toplevel ccenv in let consts_rev, wrappers = convert_arms_rev env switch.sw_consts [] in let blocks_rev, wrappers = diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml index 46fc5bf934c..df57814b933 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml @@ -1213,7 +1213,8 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list) %a (%a)" Printlambda.primitive prim H.print_list_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 | Pmake_unboxed_product _ + | Punboxed_product_field _ ), _ ) -> Misc.fatal_errorf "[%a] should have been removed by [Lambda_to_flambda.transform_primitive]" diff --git a/middle_end/flambda2/kinds/flambda_arity.ml b/middle_end/flambda2/kinds/flambda_arity.ml index 5ff02e47cd4..2e06cb1c2fe 100644 --- a/middle_end/flambda2/kinds/flambda_arity.ml +++ b/middle_end/flambda2/kinds/flambda_arity.ml @@ -15,48 +15,139 @@ (**************************************************************************) module Component = struct - type t = Singleton of Flambda_kind.With_subkind.t + type _ t = + | Singleton : Flambda_kind.With_subkind.t -> [> ] t + | Unboxed_product : _ t list -> [`Complex] t - let equal_ignoring_subkinds t1 t2 = + let rec equal_ignoring_subkinds : type uc1 uc2. uc1 t -> uc2 t -> bool = + fun t1 t2 -> match t1, t2 with | Singleton kind1, Singleton kind2 -> - Flambda_kind.With_subkind.equal_ignoring_subkind kind1 kind2 + Flambda_kind.With_subkind.equal + (Flambda_kind.With_subkind.erase_subkind kind1) + (Flambda_kind.With_subkind.erase_subkind kind2) + | Unboxed_product ts1, Unboxed_product ts2 -> + Misc.Stdlib.List.equal equal_ignoring_subkinds ts1 ts2 + | Singleton _, Unboxed_product _ | Unboxed_product _, Singleton _ -> false - let equal_exact t1 t2 = + let rec equal_exact : type uc1 uc2. uc1 t -> uc2 t -> bool = + fun t1 t2 -> match t1, t2 with | Singleton kind1, Singleton kind2 -> Flambda_kind.With_subkind.equal kind1 kind2 + | Unboxed_product ts1, Unboxed_product ts2 -> + Misc.Stdlib.List.equal equal_exact ts1 ts2 + | Singleton _, Unboxed_product _ | Unboxed_product _, Singleton _ -> false - let print ~product_above:_ ppf t = - match t with Singleton kind -> Flambda_kind.With_subkind.print ppf kind + let rec print : type uc. Format.formatter -> uc t -> unit = + fun ppf t -> + match t with + | Singleton kind -> Flambda_kind.With_subkind.print ppf kind + | Unboxed_product [] -> Format.pp_print_string ppf "void" + | Unboxed_product ts -> + Format.fprintf ppf "@[%t#%t(%a)@]" Flambda_colours.unboxed_product + Flambda_colours.pop + (Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.fprintf ppf " @<1>\u{2a2f} ") + print) + ts + + let rec unarize : type uc. uc t -> Flambda_kind.With_subkind.t list = + fun t -> + match t with + | Singleton kind -> [kind] + | Unboxed_product [] -> [] + | Unboxed_product ts -> List.concat_map unarize ts + + let component : [`Unarized] t -> Flambda_kind.With_subkind.t = + fun t -> match t with Singleton kind -> kind end -type t = Component.t list +type 'uc t = 'uc Component.t list + +module Component_for_creation = struct + type 'uc t = 'uc Component.t = + | Singleton : Flambda_kind.With_subkind.t -> [> ] t + | Unboxed_product : _ t list -> [`Complex] t + + let rec from_lambda (layout : Lambda.layout) = + match layout with + | Pvalue _ | Punboxed_float | Punboxed_int _ -> + Singleton (Flambda_kind.With_subkind.from_lambda layout) + | Punboxed_product layouts -> Unboxed_product (List.map from_lambda layouts) + | Ptop -> + Misc.fatal_error + "Cannot convert Ptop to Flambda_arity.Component_for_creation" + | Pbottom -> + Misc.fatal_error + "Cannot convert Pbottom to Flambda_arity.Component_for_creation" +end let nullary = [] -let create t = List.map (fun kind -> Component.Singleton kind) t +let create t = t -let to_list t = List.map (fun (Component.Singleton kind) -> kind) t +let create_singletons t = List.map (fun kind -> Component.Singleton kind) t let print ppf t = Format.fprintf ppf "@[%a@]" - (Format.pp_print_list (Component.print ~product_above:true) - ~pp_sep:(fun ppf () -> Format.fprintf ppf " @<1>\u{2a2f} ")) + (Format.pp_print_list Component.print ~pp_sep:(fun ppf () -> + Format.fprintf ppf " @<1>\u{2a2f} ")) t -let equal_ignoring_subkinds t1 t2 = - List.equal Component.equal_ignoring_subkinds t1 t2 +let equal_ignoring_subkinds : type uc1 uc2. uc1 t -> uc2 t -> bool = + fun t1 t2 -> Misc.Stdlib.List.equal Component.equal_ignoring_subkinds t1 t2 -let equal_exact t1 t2 = List.equal Component.equal_exact t1 t2 +let equal_exact : type uc1 uc2. uc1 t -> uc2 t -> bool = + fun t1 t2 -> Misc.Stdlib.List.equal Component.equal_exact t1 t2 -let is_singleton_value t = +let is_one_param_of_kind_value : type uc. uc t -> bool = + fun t -> match t with | [Component.Singleton kind] when Flambda_kind.equal (Flambda_kind.With_subkind.kind kind) Flambda_kind.value -> true - | [] | Component.Singleton _ :: _ -> false + | [] | Component.Singleton _ :: _ | Component.Unboxed_product _ :: _ -> false + +let unarize t = t |> List.map Component.unarize |> List.concat + +let unarized_components (t : [`Unarized] t) = List.map Component.component t + +let unarize_per_parameter t = t |> List.map Component.unarize + +let unarize_t t = t |> unarize |> create_singletons + +let fresh_idents_unarized t ~id = + List.mapi + (fun n kind -> + let ident = + Ident.create_local + (Printf.sprintf "%s_unboxed%d" (Ident.unique_name id) n) + in + ident, kind) + (unarize t) + +let cardinal_unarized t = List.length (unarize t) + +let num_params t = List.length t + +let rec must_be_one_param : type uc. uc t -> Flambda_kind.With_subkind.t option + = + fun t -> + match t with + | [Component.Singleton kind] -> Some kind + | [Component.Unboxed_product component] -> must_be_one_param component + | [] | (Component.Singleton _ | Component.Unboxed_product _) :: _ -> None + +let from_lambda_list layouts = + layouts |> List.map Component_for_creation.from_lambda |> create -let cardinal t = List.length t +let partially_apply t ~num_non_unarized_params_provided = + if num_non_unarized_params_provided < 0 + || num_non_unarized_params_provided >= List.length t + then + Misc.fatal_errorf "Bad num_non_unarized_params_provided (%d): %a" + num_non_unarized_params_provided print t + else snd (Misc.Stdlib.List.split_at num_non_unarized_params_provided t) diff --git a/middle_end/flambda2/kinds/flambda_arity.mli b/middle_end/flambda2/kinds/flambda_arity.mli index a055dc49283..8c67076d2fa 100644 --- a/middle_end/flambda2/kinds/flambda_arity.mli +++ b/middle_end/flambda2/kinds/flambda_arity.mli @@ -14,25 +14,84 @@ (* *) (**************************************************************************) -(** Arities are lists of kinds (with subkinds) used to describe things - such as the kinding of function and continuation parameter lists. *) +(** Arities are used to describe the layouts of things like function and + continuation parameter lists. -type t + In Flambda 2, variables are always assigned kinds, which are at most + register width (presently machine word width, but in the future of SIMD + widths too). Variables from Lambda which cannot be accommodated in one + register, for example if they are of an unboxed product layout, are split + by a process called unarization. -val nullary : t + Despite this, [`Complex] arities preserve the information about any unboxed + products, for later use (e.g. during Cmm translation to optimize + caml_apply). +*) -val create : Flambda_kind.With_subkind.t list -> t +type _ t -val to_list : t -> Flambda_kind.With_subkind.t list +module Component_for_creation : sig + type _ t = + | Singleton : Flambda_kind.With_subkind.t -> [> ] t + (* The nullary unboxed product is called "void". It is important to + propagate information about void layouts, even though the corresponding + variables have no runtime representation, as they interact with + currying. *) + | Unboxed_product : _ t list -> [`Complex] t -val cardinal : t -> int + val from_lambda : Lambda.layout -> [`Complex] t +end -val is_singleton_value : t -> bool +(** One component per function or continuation parameter, for example. Each + component may in turn have an arity describing an unboxed product. *) +val create : 'uc Component_for_creation.t list -> 'uc t -val print : Format.formatter -> t -> unit +val create_singletons : Flambda_kind.With_subkind.t list -> [> ] t -val equal_ignoring_subkinds : t -> t -> bool +(** "No parameters". (Not e.g. "one parameter of type void".) *) +val nullary : [> `Unarized] t + +val num_params : _ t -> int + +val print : Format.formatter -> _ t -> unit + +val equal_ignoring_subkinds : 'a t -> 'a t -> bool (* It's usually a mistake to use this function, but it's needed for [Compare]. *) -val equal_exact : t -> t -> bool +val equal_exact : 'a t -> 'a t -> bool + +val is_one_param_of_kind_value : _ t -> bool + +val must_be_one_param : _ t -> Flambda_kind.With_subkind.t option + +(** Converts, in a left-to-right depth-first order, an arity into a flattened + list of kinds for all parameters. *) +val unarize : [`Complex] t -> Flambda_kind.With_subkind.t list + +val unarized_components : [`Unarized] t -> Flambda_kind.With_subkind.t list + +(** Like [unarize] but returns one list per parameter. *) +val unarize_per_parameter : + [`Complex] t -> Flambda_kind.With_subkind.t list list + +(** Like [unarize] but returns a value of type [t]. *) +val unarize_t : [`Complex] t -> [`Unarized] t + +(** Given an arity and an identifier, produce a list of identifiers (with + corresponding kinds) whose length matches [unarize t], with names derived + from the given identifier. *) +val fresh_idents_unarized : + _ t -> id:Ident.t -> (Ident.t * Flambda_kind.With_subkind.t) list + +(** The length of the list returned by [unarize]. *) +val cardinal_unarized : _ t -> int + +(** Take a list of Lambda layouts, one per parameter, and form the + corresponding arity. *) +val from_lambda_list : Lambda.layout list -> [`Complex] t + +(** Remove the first portion of an arity to correspond to a partial + application. *) +val partially_apply : + [`Complex] t -> num_non_unarized_params_provided:int -> [`Complex] t diff --git a/middle_end/flambda2/kinds/flambda_kind.ml b/middle_end/flambda2/kinds/flambda_kind.ml index a014ec6e7f8..23dbc96da3a 100644 --- a/middle_end/flambda2/kinds/flambda_kind.ml +++ b/middle_end/flambda2/kinds/flambda_kind.ml @@ -544,6 +544,8 @@ module With_subkind = struct | Punboxed_int Pint32 -> naked_int32 | Punboxed_int Pint64 -> naked_int64 | Punboxed_int Pnativeint -> naked_nativeint + | Punboxed_product _ -> + Misc.fatal_error "Punboxed_product disallowed here, use Flambda_arity" include Container_types.Make (struct type nonrec t = t diff --git a/middle_end/flambda2/parser/fexpr_to_flambda.ml b/middle_end/flambda2/parser/fexpr_to_flambda.ml index b2d59f96a11..f839921006d 100644 --- a/middle_end/flambda2/parser/fexpr_to_flambda.ml +++ b/middle_end/flambda2/parser/fexpr_to_flambda.ml @@ -283,7 +283,8 @@ let value_kind_with_subkind_opt : | Some kind -> value_kind_with_subkind kind | None -> Flambda_kind.With_subkind.any_value -let arity a = Flambda_arity.create (List.map value_kind_with_subkind a) +let arity a = + Flambda_arity.create_singletons (List.map value_kind_with_subkind a) let const (c : Fexpr.const) : Reg_width_const.t = match c with @@ -799,11 +800,12 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = (fun ({ kind; _ } : Fexpr.kinded_parameter) -> value_kind_with_subkind_opt kind) params_and_body.params - |> Flambda_arity.create + |> Flambda_arity.create_singletons in let result_arity = match ret_arity with - | None -> Flambda_arity.create [Flambda_kind.With_subkind.any_value] + | None -> + Flambda_arity.create_singletons [Flambda_kind.With_subkind.any_value] | Some ar -> arity ar in let ( _params, @@ -835,7 +837,7 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = let my_depth, env = fresh_var env depth_var in let return_continuation, env = fresh_cont env ret_cont ~sort:Return - ~arity:(Flambda_arity.cardinal result_arity) + ~arity:(Flambda_arity.cardinal_unarized result_arity) in let exn_continuation, env = fresh_exn_cont env exn_cont in assert ( @@ -919,12 +921,13 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = let params_arity = (* CR mshinwell: This needs fixing to cope with the fact that the arities have moved onto [Apply_expr] *) - Flambda_arity.create + Flambda_arity.create_singletons (List.map (fun _ -> Flambda_kind.With_subkind.any_value) args) in let return_arity = match arities with - | None -> Flambda_arity.create [Flambda_kind.With_subkind.any_value] + | None -> + Flambda_arity.create_singletons [Flambda_kind.With_subkind.any_value] | Some { ret_arity; _ } -> arity ret_arity in let alloc = alloc_mode_for_types alloc in @@ -942,13 +945,13 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = let params_arity = (* CR mshinwell: This needs fixing to cope with the fact that the arities have moved onto [Apply_expr] *) - Flambda_arity.create + Flambda_arity.create_singletons (List.map (fun _ -> Flambda_kind.With_subkind.any_value) args) in let return_arity = (* CR mshinwell: This needs fixing to cope with the fact that the arities have moved onto [Apply_expr] *) - Flambda_arity.create [Flambda_kind.With_subkind.any_value] + Flambda_arity.create_singletons [Flambda_kind.With_subkind.any_value] in ( Call_kind.indirect_function_call_unknown_arity alloc, params_arity, diff --git a/middle_end/flambda2/parser/flambda_to_fexpr.ml b/middle_end/flambda2/parser/flambda_to_fexpr.ml index e0473c1d8e4..8e68f24cfcf 100644 --- a/middle_end/flambda2/parser/flambda_to_fexpr.ml +++ b/middle_end/flambda2/parser/flambda_to_fexpr.ml @@ -452,15 +452,20 @@ let kind_with_subkind_opt (k : Flambda_kind.With_subkind.t) : Fexpr.kind_with_subkind option = if is_default_kind_with_subkind k then None else Some (k |> kind_with_subkind) -let is_default_arity (a : Flambda_arity.t) = - match Flambda_arity.to_list a with +let is_default_arity (a : [`Unarized] Flambda_arity.t) = + match Flambda_arity.unarized_components a with | [k] -> is_default_kind_with_subkind k | _ -> false -let arity (a : Flambda_arity.t) : Fexpr.arity = - Flambda_arity.to_list a |> List.map kind_with_subkind +let complex_arity (a : [`Complex] Flambda_arity.t) : Fexpr.arity = + (* CR mshinwell: add unboxed arities to Fexpr *) + Flambda_arity.unarize a |> List.map kind_with_subkind -let arity_opt (a : Flambda_arity.t) : Fexpr.arity option = +let arity (a : [`Unarized] Flambda_arity.t) : Fexpr.arity = + (* CR mshinwell: add unboxed arities to Fexpr *) + Flambda_arity.unarized_components a |> List.map kind_with_subkind + +let arity_opt (a : [`Unarized] Flambda_arity.t) : Fexpr.arity option = if is_default_arity a then None else Some (arity a) let kinded_parameter env (kp : Bound_parameter.t) : @@ -799,7 +804,7 @@ and static_let_expr env bound_static defining_expr body : Fexpr.expr = let newer_version_of = Option.map (Env.find_code_id_exn env) (Code.newer_version_of code) in - let param_arity = Some (arity (Code.params_arity code)) in + let param_arity = Some (complex_arity (Code.params_arity code)) in let ret_arity = Code.result_arity code |> arity_opt in let recursive = recursive_flag (Code.recursive code) in let inline = @@ -1001,7 +1006,7 @@ and apply_expr env (app : Apply_expr.t) : Fexpr.expr = let arities : Fexpr.function_arities option = match Apply_expr.call_kind app with | Function { function_call = Indirect_known_arity; alloc_mode = _ } -> - let params_arity = Some (arity param_arity) in + let params_arity = Some (complex_arity param_arity) in let ret_arity = arity return_arity in Some { params_arity; ret_arity } | Function { function_call = Direct _; alloc_mode = _ } -> @@ -1015,7 +1020,7 @@ and apply_expr env (app : Apply_expr.t) : Fexpr.expr = let ret_arity = arity return_arity in Some { params_arity; ret_arity } | C_call _ -> - let params_arity = Some (arity param_arity) in + 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 = _ } diff --git a/middle_end/flambda2/simplify/apply_cont_rewrite.ml b/middle_end/flambda2/simplify/apply_cont_rewrite.ml index 9d77810f3b0..49933b48cac 100644 --- a/middle_end/flambda2/simplify/apply_cont_rewrite.ml +++ b/middle_end/flambda2/simplify/apply_cont_rewrite.ml @@ -84,7 +84,7 @@ let create ~original_params ~extra_params_and_args ~decide_param_usage = extra_params } -let original_params_arity t = Bound_parameters.arity t.original_params +(* let original_params_arity t = Bound_parameters.arity t.original_params *) let rec partition_used l usage = match l, usage with @@ -234,16 +234,14 @@ let make_rewrite rewrite ~ctx id args = let rewrite_exn_continuation rewrite id exn_cont = let exn_cont_arity = Exn_continuation.arity exn_cont in - if not - (Flambda_arity.equal_ignoring_subkinds exn_cont_arity - (original_params_arity rewrite)) - then - Misc.fatal_errorf - "Arity of exception continuation %a does not match@ [original_params] \ - (%a)" - Exn_continuation.print exn_cont Bound_parameters.print - rewrite.original_params; - assert (Flambda_arity.cardinal exn_cont_arity >= 1); + (* XXX see comment elsewhere - propagating original arity is tedious + + if not (Flambda_arity.equal_ignoring_subkinds exn_cont_arity + (original_params_arity rewrite)) then Misc.fatal_errorf "Arity of exception + continuation %a does not match@ [original_params] \ (%a)" + Exn_continuation.print exn_cont Bound_parameters.print + rewrite.original_params; *) + assert (Flambda_arity.cardinal_unarized exn_cont_arity >= 1); if List.hd rewrite.original_params_usage <> Used then Misc.fatal_errorf diff --git a/middle_end/flambda2/simplify/apply_cont_rewrite.mli b/middle_end/flambda2/simplify/apply_cont_rewrite.mli index f188d475cdd..a29f0dd824a 100644 --- a/middle_end/flambda2/simplify/apply_cont_rewrite.mli +++ b/middle_end/flambda2/simplify/apply_cont_rewrite.mli @@ -42,7 +42,7 @@ val get_used_params : t -> Bound_parameters.t * Bound_parameters.t val get_unused_params : t -> Bound_parameters.t -val original_params_arity : t -> Flambda_arity.t +(* val original_params_arity : t -> Flambda_arity.t *) type rewrite_apply_cont_ctx = | Apply_cont diff --git a/middle_end/flambda2/simplify/continuation_in_env.ml b/middle_end/flambda2/simplify/continuation_in_env.ml index 664e1360cf7..dae49153e5a 100644 --- a/middle_end/flambda2/simplify/continuation_in_env.ml +++ b/middle_end/flambda2/simplify/continuation_in_env.ml @@ -22,10 +22,10 @@ type t = cost_metrics_of_handler : Cost_metrics.t } | Non_inlinable_zero_arity of { handler : Rebuilt_expr.t Or_unknown.t } - | Non_inlinable_non_zero_arity of { arity : Flambda_arity.t } + | Non_inlinable_non_zero_arity of { arity : [`Unarized] Flambda_arity.t } | Toplevel_or_function_return_or_exn_continuation of - { arity : Flambda_arity.t } - | Invalid of { arity : Flambda_arity.t } + { arity : [`Unarized] Flambda_arity.t } + | Invalid of { arity : [`Unarized] Flambda_arity.t } let [@ocamlformat "disable"] print are_rebuilding_terms ppf t = match t with diff --git a/middle_end/flambda2/simplify/continuation_in_env.mli b/middle_end/flambda2/simplify/continuation_in_env.mli index 5e1410886f9..31fe2fd64af 100644 --- a/middle_end/flambda2/simplify/continuation_in_env.mli +++ b/middle_end/flambda2/simplify/continuation_in_env.mli @@ -30,13 +30,13 @@ type t = (** The handler, if available, is stored for [Simplify_switch_expr]. *) } - | Non_inlinable_non_zero_arity of { arity : Flambda_arity.t } + | Non_inlinable_non_zero_arity of { arity : [`Unarized] Flambda_arity.t } | Toplevel_or_function_return_or_exn_continuation of - { arity : Flambda_arity.t } - | Invalid of { arity : Flambda_arity.t } + { arity : [`Unarized] Flambda_arity.t } + | Invalid of { arity : [`Unarized] Flambda_arity.t } (** [Invalid] means that the code of the continuation handler is invalid, not that the continuation has zero uses. *) val print : Are_rebuilding_terms.t -> Format.formatter -> t -> unit -val arity : t -> Flambda_arity.t +val arity : t -> [`Unarized] Flambda_arity.t diff --git a/middle_end/flambda2/simplify/env/continuation_uses.ml b/middle_end/flambda2/simplify/env/continuation_uses.ml index 751760edb8b..42cb5321859 100644 --- a/middle_end/flambda2/simplify/env/continuation_uses.ml +++ b/middle_end/flambda2/simplify/env/continuation_uses.ml @@ -20,7 +20,7 @@ module U = One_continuation_use type t = { continuation : Continuation.t; - arity : Flambda_arity.t; + arity : [`Unarized] Flambda_arity.t; uses : U.t list } @@ -95,7 +95,7 @@ let add_uses_to_arg_maps arg_maps uses = let empty_arg_maps arity : arg_types_by_use_id = List.map (fun _ -> Apply_cont_rewrite_id.Map.empty) - (Flambda_arity.to_list arity) + (Flambda_arity.unarized_components arity) let get_arg_types_by_use_id t = add_uses_to_arg_maps (empty_arg_maps t.arity) t.uses @@ -107,10 +107,12 @@ let get_arg_types_by_use_id_for_invariant_params arity l = List.fold_left (fun arg_maps t -> if not - (Misc.Stdlib.List.is_prefix - ~equal:Flambda_kind.With_subkind.equal_ignoring_subkind - (Flambda_arity.to_list arity) - ~of_:(Flambda_arity.to_list t.arity)) + (Misc.Stdlib.List.is_prefix ~equal:Flambda_kind.equal + (Flambda_arity.unarized_components arity + |> List.map Flambda_kind.With_subkind.kind) + ~of_: + (Flambda_arity.unarized_components t.arity + |> List.map Flambda_kind.With_subkind.kind)) then Misc.fatal_errorf "Arity of invariant params@ (%a) is not a prefix of the arity of the \ diff --git a/middle_end/flambda2/simplify/env/continuation_uses.mli b/middle_end/flambda2/simplify/env/continuation_uses.mli index d92e7b3d028..7af4f7591b6 100644 --- a/middle_end/flambda2/simplify/env/continuation_uses.mli +++ b/middle_end/flambda2/simplify/env/continuation_uses.mli @@ -21,7 +21,7 @@ type t -val create : Continuation.t -> Flambda_arity.t -> t +val create : Continuation.t -> [`Unarized] Flambda_arity.t -> t val print : Format.formatter -> t -> unit @@ -50,13 +50,13 @@ val get_arg_types_by_use_id : t -> arg_types_by_use_id prefix of each of these argument lists, corresponding to the invariant params, and merges them. *) val get_arg_types_by_use_id_for_invariant_params : - Flambda_arity.t -> t list -> arg_types_by_use_id + [`Unarized] Flambda_arity.t -> t list -> arg_types_by_use_id val get_use_ids : t -> Apply_cont_rewrite_id.Set.t val number_of_uses : t -> int -val arity : t -> Flambda_arity.t +val arity : t -> [`Unarized] Flambda_arity.t val get_typing_env_no_more_than_one_use : t -> Flambda2_types.Typing_env.t option diff --git a/middle_end/flambda2/simplify/env/upwards_env.mli b/middle_end/flambda2/simplify/env/upwards_env.mli index c23158e38ef..be858282962 100644 --- a/middle_end/flambda2/simplify/env/upwards_env.mli +++ b/middle_end/flambda2/simplify/env/upwards_env.mli @@ -29,10 +29,15 @@ val add_non_inlinable_continuation : handler:Rebuilt_expr.t Or_unknown.t -> t -val add_invalid_continuation : t -> Continuation.t -> Flambda_arity.t -> t +val add_invalid_continuation : + t -> Continuation.t -> [`Unarized] Flambda_arity.t -> t val add_continuation_alias : - t -> Continuation.t -> Flambda_arity.t -> alias_for:Continuation.t -> t + t -> + Continuation.t -> + [`Unarized] Flambda_arity.t -> + alias_for:Continuation.t -> + t val add_linearly_used_inlinable_continuation : t -> @@ -44,7 +49,7 @@ val add_linearly_used_inlinable_continuation : t val add_function_return_or_exn_continuation : - t -> Continuation.t -> Flambda_arity.t -> t + t -> Continuation.t -> [`Unarized] Flambda_arity.t -> t val find_continuation : t -> Continuation.t -> Continuation_in_env.t diff --git a/middle_end/flambda2/simplify/expr_builder.ml b/middle_end/flambda2/simplify/expr_builder.ml index 10895261ed0..939a7bb1147 100644 --- a/middle_end/flambda2/simplify/expr_builder.ml +++ b/middle_end/flambda2/simplify/expr_builder.ml @@ -708,14 +708,15 @@ let rewrite_fixed_arity_continuation0 uacc cont_or_apply_cont ~use_id arity : match UE.find_apply_cont_rewrite uenv original_cont with | None -> This_continuation cont | Some rewrite when Apply_cont_rewrite.does_nothing rewrite -> - let arity_in_rewrite = Apply_cont_rewrite.original_params_arity rewrite in - if not (Flambda_arity.equal_ignoring_subkinds arity arity_in_rewrite) - then - Misc.fatal_errorf - "Arity %a provided to fixed-arity-wrapper addition function does not \ - match arity %a in rewrite:@ %a" - Flambda_arity.print arity Flambda_arity.print arity_in_rewrite - Apply_cont_rewrite.print rewrite; + (* XXX getting original_params_arity is tedious as it requires propagation + through Simplify_let_cont + + let arity_in_rewrite = Apply_cont_rewrite.original_params_arity rewrite + in if not (Flambda_arity.equal_ignoring_subkinds arity arity_in_rewrite) + then Misc.fatal_errorf "Arity %a provided to fixed-arity-wrapper addition + function does not \ match arity %a in rewrite:@ %a" Flambda_arity.print + arity Flambda_arity.print arity_in_rewrite Apply_cont_rewrite.print + rewrite; *) This_continuation cont | Some rewrite -> ( let new_wrapper params expr ~free_names @@ -743,9 +744,11 @@ let rewrite_fixed_arity_continuation0 uacc cont_or_apply_cont ~use_id arity : let params = List.map (fun _kind -> Variable.create "param") - (Flambda_arity.to_list arity) + (Flambda_arity.unarized_components arity) + in + let params = + List.map2 BP.create params (Flambda_arity.unarized_components arity) in - let params = List.map2 BP.create params (Flambda_arity.to_list arity) in let args = List.map BP.simple params in let params = Bound_parameters.create params in let apply_cont = Apply_cont.create cont ~args ~dbg:Debuginfo.none in diff --git a/middle_end/flambda2/simplify/expr_builder.mli b/middle_end/flambda2/simplify/expr_builder.mli index 2411e0786a0..1746bb8b512 100644 --- a/middle_end/flambda2/simplify/expr_builder.mli +++ b/middle_end/flambda2/simplify/expr_builder.mli @@ -133,13 +133,13 @@ val rewrite_switch_arm : Upwards_acc.t -> Apply_cont.t -> use_id:Apply_cont_rewrite_id.t -> - Flambda_arity.t -> + [`Unarized] Flambda_arity.t -> rewrite_switch_arm_result val rewrite_fixed_arity_apply : Upwards_acc.t -> use_id:Apply_cont_rewrite_id.t -> - Flambda_arity.t -> + [`Unarized] Flambda_arity.t -> Apply.t -> Upwards_acc.t * Rebuilt_expr.t diff --git a/middle_end/flambda2/simplify/flow/flow.mli b/middle_end/flambda2/simplify/flow/flow.mli index dff6a1b882d..6584d1c37db 100644 --- a/middle_end/flambda2/simplify/flow/flow.mli +++ b/middle_end/flambda2/simplify/flow/flow.mli @@ -82,7 +82,7 @@ module Acc : sig val add_apply_conts : result_cont:(Apply_cont_rewrite_id.t * Continuation.t) option -> exn_cont:Apply_cont_rewrite_id.t * Exn_continuation.t -> - result_arity:Flambda_arity.t -> + result_arity:[`Unarized] Flambda_arity.t -> t -> t diff --git a/middle_end/flambda2/simplify/flow/flow_acc.ml b/middle_end/flambda2/simplify/flow/flow_acc.ml index b205dbc2799..9d09ad470c6 100644 --- a/middle_end/flambda2/simplify/flow/flow_acc.ml +++ b/middle_end/flambda2/simplify/flow/flow_acc.ml @@ -277,7 +277,7 @@ let add_apply_conts ~result_cont ~exn_cont ~result_arity t = | None -> apply_cont_args | Some (rewrite_id, result_cont) -> add_func_result result_cont rewrite_id - ~result_arity:(Flambda_arity.cardinal result_arity) + ~result_arity:(Flambda_arity.cardinal_unarized result_arity) ~extra_args:[] apply_cont_args in { elt with apply_cont_args }) diff --git a/middle_end/flambda2/simplify/flow/flow_acc.mli b/middle_end/flambda2/simplify/flow/flow_acc.mli index 53cec19ac56..ee0ce5ca39d 100644 --- a/middle_end/flambda2/simplify/flow/flow_acc.mli +++ b/middle_end/flambda2/simplify/flow/flow_acc.mli @@ -97,7 +97,7 @@ val add_used_in_current_handler : Name_occurrences.t -> t -> t val add_apply_conts : result_cont:(Apply_cont_rewrite_id.t * Continuation.t) option -> exn_cont:Apply_cont_rewrite_id.t * Exn_continuation.t -> - result_arity:Flambda_arity.t -> + result_arity:[`Unarized] Flambda_arity.t -> t -> t diff --git a/middle_end/flambda2/simplify/inlining/call_site_inlining_decision.ml b/middle_end/flambda2/simplify/inlining/call_site_inlining_decision.ml index 84287423960..dc74eb18edb 100644 --- a/middle_end/flambda2/simplify/inlining/call_site_inlining_decision.ml +++ b/middle_end/flambda2/simplify/inlining/call_site_inlining_decision.ml @@ -108,7 +108,8 @@ let speculative_inlining dacc ~apply ~function_type ~simplify_expr ~return_arity UE.add_function_return_or_exn_continuation (UE.create (DA.are_rebuilding_terms dacc)) (Exn_continuation.exn_handler exn_continuation) - (Flambda_arity.create [Flambda_kind.With_subkind.any_value]) + (Flambda_arity.create_singletons + [Flambda_kind.With_subkind.any_value]) in let uenv = match Apply.continuation apply with diff --git a/middle_end/flambda2/simplify/inlining/call_site_inlining_decision.mli b/middle_end/flambda2/simplify/inlining/call_site_inlining_decision.mli index 1cbaba44152..d593eb39ab2 100644 --- a/middle_end/flambda2/simplify/inlining/call_site_inlining_decision.mli +++ b/middle_end/flambda2/simplify/inlining/call_site_inlining_decision.mli @@ -21,7 +21,7 @@ val make_decision : simplify_expr:Expr.t Simplify_common.expr_simplifier -> function_type:Flambda2_types.Function_type.t -> apply:Apply.t -> - return_arity:Flambda_arity.t -> + return_arity:[`Unarized] Flambda_arity.t -> Call_site_inlining_decision_type.t val get_rec_info : diff --git a/middle_end/flambda2/simplify/simplify.ml b/middle_end/flambda2/simplify/simplify.ml index 795c1338fab..8a2b8528e7a 100644 --- a/middle_end/flambda2/simplify/simplify.ml +++ b/middle_end/flambda2/simplify/simplify.ml @@ -43,7 +43,7 @@ let run ~cmx_loader ~round unit = let dacc = DA.create denv Continuation_uses_env.empty in let body, uacc = Simplify_expr.simplify_toplevel dacc (FU.body unit) ~return_continuation - ~return_arity:(Flambda_arity.create [K.With_subkind.any_value]) + ~return_arity:(Flambda_arity.create_singletons [K.With_subkind.any_value]) ~exn_continuation in let body = Rebuilt_expr.to_expr body (UA.are_rebuilding_terms uacc) in diff --git a/middle_end/flambda2/simplify/simplify_apply_expr.ml b/middle_end/flambda2/simplify/simplify_apply_expr.ml index 02579724c8b..bfa80b56990 100644 --- a/middle_end/flambda2/simplify/simplify_apply_expr.ml +++ b/middle_end/flambda2/simplify/simplify_apply_expr.ml @@ -83,7 +83,8 @@ let simplify_direct_tuple_application ~simplify_expr dacc apply ~down_to_up = let dbg = Apply.dbg apply in let n = - Flambda_arity.cardinal (Code_metadata.params_arity callee's_code_metadata) + Flambda_arity.cardinal_unarized + (Code_metadata.params_arity callee's_code_metadata) in (* Split the tuple argument from other potential over application arguments *) let tuple, over_application_args = @@ -92,7 +93,7 @@ let simplify_direct_tuple_application ~simplify_expr dacc apply | _ -> Misc.fatal_errorf "Empty argument list for direct application" in let over_application_arity = - List.tl (Flambda_arity.to_list (Apply.args_arity apply)) + List.tl (Flambda_arity.unarize (Apply.args_arity apply)) in (* Create the list of variables and projections *) let vars_and_fields = @@ -106,7 +107,7 @@ let simplify_direct_tuple_application ~simplify_expr dacc apply let args_arity = (* The components of the tuple must always be of kind [Value] (in Lambda, [layout_field]). *) - Flambda_arity.create + Flambda_arity.create_singletons (List.init n (fun _ -> K.With_subkind.any_value) @ over_application_arity) in @@ -236,7 +237,7 @@ let simplify_direct_full_application ~simplify_expr dacc apply function_type | Return apply_return_continuation, Ok result_types -> Result_types.pattern_match result_types ~f:(fun ~params ~results env_extension -> - if Flambda_arity.cardinal params_arity + if Flambda_arity.cardinal_unarized params_arity <> Bound_parameters.cardinal params then Misc.fatal_errorf @@ -244,7 +245,7 @@ let simplify_direct_full_application ~simplify_expr dacc apply function_type types structure:@ %a@ for application:@ %a" Flambda_arity.print params_arity Result_types.print result_types Apply.print apply; - if Flambda_arity.cardinal result_arity + if Flambda_arity.cardinal_unarized result_arity <> Bound_parameters.cardinal results then Misc.fatal_errorf @@ -270,7 +271,9 @@ let simplify_direct_full_application ~simplify_expr dacc apply function_type arg)) denv params args in - let result_arity = Flambda_arity.to_list result_arity in + let result_arity = + Flambda_arity.unarized_components result_arity + in let denv = List.fold_left2 (fun denv kind result -> @@ -322,9 +325,10 @@ let simplify_direct_full_application ~simplify_expr dacc apply function_type let simplify_direct_partial_application ~simplify_expr dacc apply ~callee's_code_id ~callee's_code_metadata ~callee's_function_slot - ~param_arity ~result_arity ~recursive ~down_to_up ~coming_from_indirect + ~param_arity ~args_arity ~result_arity ~recursive ~down_to_up + ~coming_from_indirect ~(closure_alloc_mode_from_type : Alloc_mode.For_types.t) ~current_region - ~num_trailing_local_params = + ~num_trailing_local_non_unarized_params = (* Partial-applications are converted in full applications. Let's assume that [foo] takes 6 arguments. Then [foo a b c] gets transformed into: @@ -362,14 +366,18 @@ let simplify_direct_partial_application ~simplify_expr dacc apply Inlining_helpers.( inlined_attribute_on_partial_application_msg Unrolled)) | Default_inlined | Hint_inlined -> ()); - let arity = Flambda_arity.cardinal param_arity in - let args_arity = List.length args in - assert (arity > args_arity); - let applied_args, remaining_param_arity = + let num_non_unarized_params = Flambda_arity.num_params param_arity in + let num_non_unarized_args = Flambda_arity.num_params args_arity in + assert (num_non_unarized_params > num_non_unarized_args); + let remaining_param_arity = + Flambda_arity.partially_apply param_arity + ~num_non_unarized_params_provided:(Flambda_arity.num_params args_arity) + in + let applied_unarized_args, _ = Misc.Stdlib.List.map2_prefix (fun arg kind -> arg, kind) args - (Flambda_arity.to_list param_arity) + (Flambda_arity.unarize param_arity) in let wrapper_var = Variable.create "partial_app" in let compilation_unit = Compilation_unit.get_current_exn () in @@ -381,13 +389,17 @@ let simplify_direct_partial_application ~simplify_expr dacc apply (* If the closure has a local suffix, and we've supplied enough args to hit it, then the closure must be local (because the args or closure might be). *) - let num_leading_heap_params = arity - num_trailing_local_params in - if args_arity <= num_leading_heap_params - then Alloc_mode.For_allocations.heap, num_trailing_local_params + let num_leading_heap_non_unarized_params = + num_non_unarized_params - num_trailing_local_non_unarized_params + in + if num_non_unarized_args <= num_leading_heap_non_unarized_params + then Alloc_mode.For_allocations.heap, num_trailing_local_non_unarized_params else - let num_supplied_local_args = args_arity - num_leading_heap_params in + let num_supplied_local_args = + num_non_unarized_args - num_leading_heap_non_unarized_params + in ( Alloc_mode.For_allocations.local ~region:current_region, - num_trailing_local_params - num_supplied_local_args ) + num_trailing_local_non_unarized_params - num_supplied_local_args ) in (match closure_alloc_mode_from_type with | Heap_or_local -> () @@ -427,7 +439,7 @@ let simplify_direct_partial_application ~simplify_expr dacc apply (fun kind -> let param = Variable.create "param" in Bound_parameter.create param kind) - remaining_param_arity + (Flambda_arity.unarize remaining_param_arity) |> Bound_parameters.create in let call_kind = @@ -478,8 +490,8 @@ let simplify_direct_partial_application ~simplify_expr dacc apply let applied_callee = applied_value (Apply.callee apply, K.With_subkind.any_value) in - let applied_args = List.map applied_value applied_args in - let applied_values = applied_callee :: applied_args in + let applied_unarized_args = List.map applied_value applied_unarized_args in + let applied_values = applied_callee :: applied_unarized_args in let my_closure = Variable.create "my_closure" in let my_region = Variable.create "my_region" in let my_depth = Variable.create "my_depth" in @@ -496,7 +508,8 @@ let simplify_direct_partial_application ~simplify_expr dacc apply in let callee = arg applied_callee in let args = - List.map arg applied_args @ Bound_parameters.simples remaining_params + List.map arg applied_unarized_args + @ Bound_parameters.simples remaining_params in let full_application = Apply.create ~callee ~continuation:(Return return_continuation) @@ -724,9 +737,9 @@ let simplify_direct_function_call ~simplify_expr dacc apply ~apply_alloc_mode ~current_region ~callee's_code_id ~callee's_code_metadata ~down_to_up else - let args = Apply.args apply in - let provided_num_args = List.length args in - let num_params = Flambda_arity.cardinal params_arity in + let args_arity = Apply.args_arity apply in + let num_params = Flambda_arity.num_params params_arity in + let provided_num_args = Flambda_arity.num_params args_arity in let result_arity_of_application = Apply.return_arity apply in if provided_num_args = num_params then ( @@ -755,7 +768,7 @@ let simplify_direct_function_call ~simplify_expr dacc apply else if provided_num_args > num_params then ( (* See comment above. *) - if not (Flambda_arity.is_singleton_value result_arity) + if not (Flambda_arity.is_one_param_of_kind_value result_arity) then Misc.fatal_errorf "Non-singleton-value return arity for overapplied OCaml function:@ \ @@ -767,7 +780,9 @@ let simplify_direct_function_call ~simplify_expr dacc apply else if provided_num_args > 0 && provided_num_args < num_params then ( (* See comment above. *) - if not (Flambda_arity.is_singleton_value result_arity_of_application) + if not + (Flambda_arity.is_one_param_of_kind_value + result_arity_of_application) then Misc.fatal_errorf "Non-singleton-value return arity for partially-applied OCaml \ @@ -775,9 +790,10 @@ let simplify_direct_function_call ~simplify_expr dacc apply Apply.print apply; simplify_direct_partial_application ~simplify_expr dacc apply ~callee's_code_id ~callee's_code_metadata ~callee's_function_slot - ~param_arity:params_arity ~result_arity ~recursive ~down_to_up - ~coming_from_indirect ~closure_alloc_mode_from_type ~current_region - ~num_trailing_local_params: + ~param_arity:params_arity ~args_arity ~result_arity ~recursive + ~down_to_up ~coming_from_indirect ~closure_alloc_mode_from_type + ~current_region + ~num_trailing_local_non_unarized_params: (Code_metadata.num_trailing_local_params callee's_code_metadata)) else Misc.fatal_errorf @@ -942,7 +958,7 @@ let simplify_apply_shared dacc apply = "Argument kind %a from arity does not match kind from type %a for \ application:@ %a" K.print kind T.print arg_type Apply.print apply) - (Flambda_arity.to_list (Apply.args_arity apply)) + (Flambda_arity.unarize (Apply.args_arity apply)) arg_types; let inlining_state = Inlining_state.meet @@ -996,7 +1012,8 @@ let simplify_method_call dacc apply ~callee_ty ~kind:_ ~obj ~arg_types let args_arity = Apply.args_arity apply in let args_arity_from_types = T.arity_of_list arg_types in if not - (Flambda_arity.equal_ignoring_subkinds args_arity_from_types args_arity) + (Flambda_arity.equal_ignoring_subkinds args_arity_from_types + (Flambda_arity.unarize_t args_arity)) then Misc.fatal_errorf "Arity %a of [Apply] arguments doesn't match parameter arity %a of \ @@ -1055,7 +1072,8 @@ let simplify_c_call ~simplify_expr dacc apply ~callee_ty ~arg_types ~down_to_up callee_kind T.print callee_ty; let args_arity_from_types = T.arity_of_list arg_types in if not - (Flambda_arity.equal_ignoring_subkinds args_arity_from_types args_arity) + (Flambda_arity.equal_ignoring_subkinds args_arity_from_types + (Flambda_arity.unarize_t args_arity)) then Misc.fatal_errorf "Arity %a of [Apply] arguments doesn't match parameter arity %a of C \ diff --git a/middle_end/flambda2/simplify/simplify_common.ml b/middle_end/flambda2/simplify/simplify_common.ml index 31df021c87f..f7648580eeb 100644 --- a/middle_end/flambda2/simplify/simplify_common.ml +++ b/middle_end/flambda2/simplify/simplify_common.ml @@ -33,7 +33,7 @@ type simplify_toplevel = Downwards_acc.t -> Expr.t -> return_continuation:Continuation.t -> - return_arity:Flambda_arity.t -> + return_arity:[`Unarized] Flambda_arity.t -> exn_continuation:Continuation.t -> Rebuilt_expr.t * Upwards_acc.t @@ -41,7 +41,7 @@ type simplify_function_body = Downwards_acc.t -> Expr.t -> return_continuation:Continuation.t -> - return_arity:Flambda_arity.t -> + return_arity:[`Unarized] Flambda_arity.t -> exn_continuation:Continuation.t -> loopify_state:Loopify_state.t -> params:Bound_parameters.t -> @@ -96,15 +96,26 @@ let split_direct_over_application apply let callee's_params_arity = Code_metadata.params_arity callee's_code_metadata in - let arity = Flambda_arity.cardinal callee's_params_arity in + let num_non_unarized_params = + Flambda_arity.num_params callee's_params_arity + in + let args_arity = Apply.args_arity apply in + let num_non_unarized_args = Flambda_arity.num_params args_arity in + assert (num_non_unarized_params < num_non_unarized_args); let args = Apply.args apply in - assert (arity < List.length args); - let first_args, remaining_args = Misc.Stdlib.List.split_at arity args in - let _, remaining_arity = - Misc.Stdlib.List.split_at arity - (Apply.args_arity apply |> Flambda_arity.to_list) + let first_args, remaining_args = + Misc.Stdlib.List.split_at + (Flambda_arity.cardinal_unarized callee's_params_arity) + args + in + let remaining_arity = + Flambda_arity.partially_apply args_arity + ~num_non_unarized_params_provided:num_non_unarized_params in - assert (List.compare_lengths remaining_args remaining_arity = 0); + assert ( + List.compare_length_with remaining_args + (Flambda_arity.cardinal_unarized remaining_arity) + = 0); let func_var = Variable.create "full_apply" in let contains_no_escaping_local_allocs = Code_metadata.contains_no_escaping_local_allocs callee's_code_metadata @@ -141,8 +152,7 @@ let split_direct_over_application apply in Apply.create ~callee:(Simple.var func_var) ~continuation (Apply.exn_continuation apply) - ~args:remaining_args - ~args_arity:(Flambda_arity.create remaining_arity) + ~args:remaining_args ~args_arity:remaining_arity ~return_arity:(Apply.return_arity apply) ~call_kind: (Call_kind.indirect_function_call_unknown_arity apply_alloc_mode) @@ -170,7 +180,7 @@ let split_direct_over_application apply List.mapi (fun i kind -> BP.create (Variable.create ("result" ^ string_of_int i)) kind) - (Flambda_arity.to_list (Apply.return_arity apply)) + (Flambda_arity.unarized_components (Apply.return_arity apply)) in let call_return_continuation, call_return_continuation_free_names = match Apply.continuation apply with diff --git a/middle_end/flambda2/simplify/simplify_common.mli b/middle_end/flambda2/simplify/simplify_common.mli index 0470bb1c6ec..a9ed859c235 100644 --- a/middle_end/flambda2/simplify/simplify_common.mli +++ b/middle_end/flambda2/simplify/simplify_common.mli @@ -76,7 +76,7 @@ type simplify_toplevel = Downwards_acc.t -> Expr.t -> return_continuation:Continuation.t -> - return_arity:Flambda_arity.t -> + return_arity:[`Unarized] Flambda_arity.t -> exn_continuation:Continuation.t -> Rebuilt_expr.t * Upwards_acc.t @@ -84,7 +84,7 @@ type simplify_function_body = Downwards_acc.t -> Expr.t -> return_continuation:Continuation.t -> - return_arity:Flambda_arity.t -> + return_arity:[`Unarized] Flambda_arity.t -> exn_continuation:Continuation.t -> loopify_state:Loopify_state.t -> params:Bound_parameters.t -> diff --git a/middle_end/flambda2/simplify/simplify_expr.ml b/middle_end/flambda2/simplify/simplify_expr.ml index 5a67c57085e..07259ada94d 100644 --- a/middle_end/flambda2/simplify/simplify_expr.ml +++ b/middle_end/flambda2/simplify/simplify_expr.ml @@ -68,7 +68,7 @@ let simplify_toplevel_common dacc simplify ~params ~implicit_params in let uenv = UE.add_function_return_or_exn_continuation uenv exn_continuation - (Flambda_arity.create [K.With_subkind.any_value]) + (Flambda_arity.create_singletons [K.With_subkind.any_value]) in let uacc = UA.create ~flow_result ~compute_slot_offsets:true uenv dacc diff --git a/middle_end/flambda2/simplify/simplify_set_of_closures.ml b/middle_end/flambda2/simplify/simplify_set_of_closures.ml index feb6d2c5070..a0b52ad64d0 100644 --- a/middle_end/flambda2/simplify/simplify_set_of_closures.ml +++ b/middle_end/flambda2/simplify/simplify_set_of_closures.ml @@ -346,7 +346,7 @@ let simplify_function0 context ~outer_dacc function_slot_opt code_id code BP.create (Variable.create ("result" ^ string_of_int i)) kind_with_subkind) - (Flambda_arity.to_list result_arity) + (Flambda_arity.unarized_components result_arity) |> Bound_parameters.create in let { params; @@ -739,7 +739,7 @@ let simplify_non_lifted_set_of_closures0 dacc bound_vars ~closure_bound_vars Cost_metrics. { cost_metrics = Code_metadata.cost_metrics code_metadata; params_arity = - Flambda_arity.cardinal (Code_metadata.params_arity code_metadata) + Flambda_arity.num_params (Code_metadata.params_arity code_metadata) } in Simplified_named.create_with_known_free_names ~find_code_characteristics diff --git a/middle_end/flambda2/simplify/simplify_switch_expr.ml b/middle_end/flambda2/simplify/simplify_switch_expr.ml index 0ef1827bd8d..6d19da1c464 100644 --- a/middle_end/flambda2/simplify/simplify_switch_expr.ml +++ b/middle_end/flambda2/simplify/simplify_switch_expr.ml @@ -104,9 +104,9 @@ let rebuild_arm uacc arm (action, use_id, arity, env_at_use) | Non_inlinable_zero_arity { handler = Known handler } -> check_handler ~handler ~action | Non_inlinable_zero_arity { handler = Unknown } -> Some action - | Invalid _ -> None - | Non_inlinable_non_zero_arity _ - | Toplevel_or_function_return_or_exn_continuation _ -> + | Invalid _ | Toplevel_or_function_return_or_exn_continuation _ -> + None + | Non_inlinable_non_zero_arity _ -> Misc.fatal_errorf "Inconsistency for %a between [Apply_cont.is_goto] and \ continuation environment in [UA]:@ %a" @@ -377,7 +377,7 @@ let simplify_arm ~typing_env_at_use ~scrutinee_ty arm action (arms, dacc) = let arity = arg_types |> List.map (fun ty -> K.With_subkind.anything (T.kind ty)) - |> Flambda_arity.create + |> Flambda_arity.create_singletons in let action = Apply_cont.update_args action ~args in let dacc = diff --git a/middle_end/flambda2/simplify_shared/inlining_helpers.ml b/middle_end/flambda2/simplify_shared/inlining_helpers.ml index a1369782303..386bd6843c3 100644 --- a/middle_end/flambda2/simplify_shared/inlining_helpers.ml +++ b/middle_end/flambda2/simplify_shared/inlining_helpers.ml @@ -72,7 +72,7 @@ let wrap_inlined_body_for_exn_extra_args acc ~extra_args ~apply_exn_continuation let kinded_params = List.map (fun k -> Bound_parameter.create (Variable.create "wrapper_return") k) - (Flambda_arity.to_list result_arity) + (Flambda_arity.unarized_components result_arity) in let trap_action = Trap_action.Pop { exn_handler = wrapper; raise_kind = None } diff --git a/middle_end/flambda2/simplify_shared/inlining_helpers.mli b/middle_end/flambda2/simplify_shared/inlining_helpers.mli index c1540a75ed5..27ab89d8799 100644 --- a/middle_end/flambda2/simplify_shared/inlining_helpers.mli +++ b/middle_end/flambda2/simplify_shared/inlining_helpers.mli @@ -46,7 +46,7 @@ val wrap_inlined_body_for_exn_extra_args : extra_args:(Simple.t * Flambda_kind.With_subkind.t) list -> apply_exn_continuation:Exn_continuation.t -> apply_return_continuation:Flambda.Apply.Result_continuation.t -> - result_arity:Flambda_arity.t -> + result_arity:[`Unarized] Flambda_arity.t -> make_inlined_body: ('acc -> apply_exn_continuation:Continuation.t -> diff --git a/middle_end/flambda2/simplify_shared/slot_offsets.ml b/middle_end/flambda2/simplify_shared/slot_offsets.ml index f516398b4e3..6d87dd3d4b8 100644 --- a/middle_end/flambda2/simplify_shared/slot_offsets.ml +++ b/middle_end/flambda2/simplify_shared/slot_offsets.ml @@ -727,7 +727,7 @@ end = struct let module CM = Code_metadata in let is_tupled = CM.is_tupled code_metadata in let params_arity = CM.params_arity code_metadata in - let arity = Flambda_arity.cardinal params_arity in + let arity = Flambda_arity.num_params params_arity in if (arity = 0 || arity = 1) && not is_tupled then 2 else 3 in let s = create_slot ~size (Function_slot function_slot) Unassigned in diff --git a/middle_end/flambda2/terms/apply_expr.ml b/middle_end/flambda2/terms/apply_expr.ml index 35d629cd4ac..dd4cb428de1 100644 --- a/middle_end/flambda2/terms/apply_expr.ml +++ b/middle_end/flambda2/terms/apply_expr.ml @@ -73,8 +73,8 @@ type t = continuation : Result_continuation.t; exn_continuation : Exn_continuation.t; args : Simple.t list; - args_arity : Flambda_arity.t; - return_arity : Flambda_arity.t; + args_arity : [`Complex] Flambda_arity.t; + return_arity : [`Unarized] Flambda_arity.t; call_kind : Call_kind.t; dbg : Debuginfo.t; inlined : Inlined_attribute.t; @@ -158,12 +158,12 @@ let invariant "For [C_call] applications the callee must be directly specified as a \ [Symbol]:@ %a" print t; - match Flambda_arity.to_list return_arity with + match Flambda_arity.unarized_components return_arity with | [] | [_] -> () | _ :: _ :: _ -> Misc.fatal_errorf "Illegal return arity for C call:@ %a" Flambda_arity.print return_arity)); - if List.compare_lengths args (Flambda_arity.to_list args_arity) <> 0 + if List.compare_lengths args (Flambda_arity.unarize args_arity) <> 0 then Misc.fatal_errorf "Length of argument and arity lists disagree in [Apply]:@ %a" print t diff --git a/middle_end/flambda2/terms/apply_expr.mli b/middle_end/flambda2/terms/apply_expr.mli index ddf9bda1a7a..73f0215e315 100644 --- a/middle_end/flambda2/terms/apply_expr.mli +++ b/middle_end/flambda2/terms/apply_expr.mli @@ -51,8 +51,8 @@ val create : continuation:Result_continuation.t -> Exn_continuation.t -> args:Simple.t list -> - args_arity:Flambda_arity.t -> - return_arity:Flambda_arity.t -> + args_arity:[`Complex] Flambda_arity.t -> + return_arity:[`Unarized] Flambda_arity.t -> call_kind:Call_kind.t -> Debuginfo.t -> inlined:Inlined_attribute.t -> @@ -77,10 +77,10 @@ val callee : t -> Simple.t val args : t -> Simple.t list (** The arity of the arguments being applied. *) -val args_arity : t -> Flambda_arity.t +val args_arity : t -> [`Complex] Flambda_arity.t (** The arity of the result(s) of the application. *) -val return_arity : t -> Flambda_arity.t +val return_arity : t -> [`Unarized] Flambda_arity.t (** Information about what kind of call is involved (direct function call, method call, etc). *) @@ -110,7 +110,7 @@ val with_continuations : t -> Result_continuation.t -> Exn_continuation.t -> t val with_exn_continuation : t -> Exn_continuation.t -> t (** Change the arguments of an application *) -val with_args : t -> Simple.t list -> args_arity:Flambda_arity.t -> t +val with_args : t -> Simple.t list -> args_arity:[`Complex] Flambda_arity.t -> t (** Change the call kind of an application. *) val with_call_kind : t -> Call_kind.t -> t diff --git a/middle_end/flambda2/terms/code_metadata.ml b/middle_end/flambda2/terms/code_metadata.ml index 8a8dcab3f14..0bbe47ef5d4 100644 --- a/middle_end/flambda2/terms/code_metadata.ml +++ b/middle_end/flambda2/terms/code_metadata.ml @@ -17,9 +17,9 @@ type t = { code_id : Code_id.t; newer_version_of : Code_id.t option; - params_arity : Flambda_arity.t; + params_arity : [`Complex] Flambda_arity.t; num_trailing_local_params : int; - result_arity : Flambda_arity.t; + result_arity : [`Unarized] Flambda_arity.t; result_types : Result_types.t Or_unknown_or_bottom.t; contains_no_escaping_local_allocs : bool; stub : bool; @@ -58,7 +58,7 @@ module Code_metadata_accessors (X : Metadata_view_type) = struct let num_leading_heap_params t = let { params_arity; num_trailing_local_params; _ } = metadata t in - let n = Flambda_arity.cardinal params_arity - num_trailing_local_params in + let n = Flambda_arity.num_params params_arity - num_trailing_local_params in assert (n >= 0); (* see [create] *) n @@ -124,9 +124,9 @@ include Code_metadata_accessors [@inlined hint] (Metadata_view) type 'a create_type = Code_id.t -> newer_version_of:Code_id.t option -> - params_arity:Flambda_arity.t -> + params_arity:[`Complex] Flambda_arity.t -> num_trailing_local_params:int -> - result_arity:Flambda_arity.t -> + result_arity:[`Unarized] Flambda_arity.t -> result_types:Result_types.t Or_unknown_or_bottom.t -> contains_no_escaping_local_allocs:bool -> stub:bool -> @@ -161,7 +161,7 @@ let createk k code_id ~newer_version_of ~params_arity ~num_trailing_local_params | true, (Always_inline | Unroll _) -> Misc.fatal_error "Stubs may not be annotated as [Always_inline] or [Unroll]"); if num_trailing_local_params < 0 - || num_trailing_local_params > Flambda_arity.cardinal params_arity + || num_trailing_local_params > Flambda_arity.cardinal_unarized params_arity then Misc.fatal_errorf "Illegal num_trailing_local_params=%d for params arity: %a" @@ -270,22 +270,22 @@ let [@ocamlformat "disable"] print ppf (if not is_a_functor then Flambda_colours.elide else C.none) is_a_functor Flambda_colours.pop - (if Flambda_arity.is_singleton_value params_arity + (if Flambda_arity.is_one_param_of_kind_value params_arity then Flambda_colours.elide else Flambda_colours.none) Flambda_colours.pop Flambda_arity.print params_arity - (if Flambda_arity.is_singleton_value params_arity + (if Flambda_arity.is_one_param_of_kind_value params_arity then Flambda_colours.elide else Flambda_colours.none) Flambda_colours.pop num_trailing_local_params - (if Flambda_arity.is_singleton_value result_arity + (if Flambda_arity.is_one_param_of_kind_value result_arity then Flambda_colours.elide else Flambda_colours.none) Flambda_colours.pop Flambda_arity.print result_arity - (if Flambda_arity.is_singleton_value result_arity + (if Flambda_arity.is_one_param_of_kind_value result_arity then Flambda_colours.elide else Flambda_colours.none) Flambda_colours.pop diff --git a/middle_end/flambda2/terms/code_metadata.mli b/middle_end/flambda2/terms/code_metadata.mli index 916657b1ab3..67b88fd71c4 100644 --- a/middle_end/flambda2/terms/code_metadata.mli +++ b/middle_end/flambda2/terms/code_metadata.mli @@ -31,13 +31,14 @@ module type Code_metadata_accessors_result_type = sig val newer_version_of : 'a t -> Code_id.t option - val params_arity : 'a t -> Flambda_arity.t + val params_arity : 'a t -> [`Complex] Flambda_arity.t val num_leading_heap_params : 'a t -> int + (* XXX rename to num_trailing_local_non_unarized_params *) val num_trailing_local_params : 'a t -> int - val result_arity : 'a t -> Flambda_arity.t + val result_arity : 'a t -> [`Unarized] Flambda_arity.t val result_types : 'a t -> Result_types.t Or_unknown_or_bottom.t @@ -82,9 +83,9 @@ include Code_metadata_accessors_result_type with type 'a t := t type 'a create_type = Code_id.t -> newer_version_of:Code_id.t option -> - params_arity:Flambda_arity.t -> + params_arity:[`Complex] Flambda_arity.t -> num_trailing_local_params:int -> - result_arity:Flambda_arity.t -> + result_arity:[`Unarized] Flambda_arity.t -> result_types:Result_types.t Or_unknown_or_bottom.t -> contains_no_escaping_local_allocs:bool -> stub:bool -> diff --git a/middle_end/flambda2/terms/exn_continuation.ml b/middle_end/flambda2/terms/exn_continuation.ml index 1283eb74b51..e41d927ec34 100644 --- a/middle_end/flambda2/terms/exn_continuation.ml +++ b/middle_end/flambda2/terms/exn_continuation.ml @@ -108,7 +108,7 @@ let arity t = let exn_bucket_kind = Flambda_kind.With_subkind.create Flambda_kind.value Anything in - Flambda_arity.create (exn_bucket_kind :: extra_args) + Flambda_arity.create_singletons (exn_bucket_kind :: extra_args) let with_exn_handler t exn_handler = { t with exn_handler } diff --git a/middle_end/flambda2/terms/exn_continuation.mli b/middle_end/flambda2/terms/exn_continuation.mli index 8de74d2bc6d..911a699dd18 100644 --- a/middle_end/flambda2/terms/exn_continuation.mli +++ b/middle_end/flambda2/terms/exn_continuation.mli @@ -46,7 +46,7 @@ val extra_args : t -> (Simple.t * Flambda_kind.With_subkind.t) list (** The arity of the given exception continuation, taking into account both the exception bucket argument and any [extra_args]. *) -val arity : t -> Flambda_arity.t +val arity : t -> [> `Unarized] Flambda_arity.t val with_exn_handler : t -> Continuation.t -> t diff --git a/middle_end/flambda2/to_cmm/to_cmm_env.ml b/middle_end/flambda2/to_cmm/to_cmm_env.ml index 467e18c9970..c0fc3795ecf 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_env.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_env.ml @@ -360,7 +360,7 @@ let add_exn_handler env k arity = let env = { env with exn_handlers = Continuation.Set.add k env.exn_handlers } in - match Flambda_arity.to_list arity with + match Flambda_arity.unarized_components arity with | [] -> Misc.fatal_error "Exception handlers must have at least one parameter" | [_] -> env, [] | _ :: extra_args -> diff --git a/middle_end/flambda2/to_cmm/to_cmm_env.mli b/middle_end/flambda2/to_cmm/to_cmm_env.mli index b84e60fafb0..34cce6d8c43 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_env.mli +++ b/middle_end/flambda2/to_cmm/to_cmm_env.mli @@ -325,7 +325,7 @@ val add_inline_cont : val add_exn_handler : t -> Continuation.t -> - Flambda_arity.t -> + [`Unarized] Flambda_arity.t -> t * (Backend_var.t * Flambda_kind.With_subkind.t) list (** Return whether the given continuation has been registered as an exception diff --git a/middle_end/flambda2/to_cmm/to_cmm_expr.ml b/middle_end/flambda2/to_cmm/to_cmm_expr.ml index b92597c14dd..9eeca713a88 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_expr.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_expr.ml @@ -108,9 +108,15 @@ let translate_apply0 ~dbg_with_inlined:dbg env res apply = Lambda.Rc_normal | Nontail -> Lambda.Rc_nontail in - let args_arity = Apply.args_arity apply |> Flambda_arity.to_list in + let args_arity = + Apply.args_arity apply |> Flambda_arity.unarize_per_parameter + in let return_arity = Apply.return_arity apply in - let args_ty = List.map C.extended_machtype_of_kind args_arity in + let args_ty = + List.map + (fun kinds -> List.map C.extended_machtype_of_kind kinds |> Array.concat) + args_arity + in let return_ty = C.extended_machtype_of_return_arity return_arity in match Apply.call_kind apply with | Function { function_call = Direct code_id; alloc_mode = _ } -> ( @@ -176,7 +182,7 @@ let translate_apply0 ~dbg_with_inlined:dbg env res apply = in let returns = Apply.returns apply in let wrap = - match Flambda_arity.to_list return_arity with + match Flambda_arity.unarized_components return_arity with (* Returned int32 values need to be sign_extended because it's not clear whether C code that returns an int32 returns one that is sign extended or not. There is no need to wrap other return arities. Note that @@ -196,7 +202,7 @@ let translate_apply0 ~dbg_with_inlined:dbg env res apply = in let ty_args = List.map C.exttype_of_kind - (Flambda_arity.to_list (Apply.args_arity apply) + (Flambda_arity.unarize (Apply.args_arity apply) |> List.map K.With_subkind.kind) in ( wrap dbg diff --git a/middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml b/middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml index afda54dd1fc..d28209484ef 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml @@ -42,10 +42,14 @@ let get_func_decl_params_arity t code_id = cmm_helpers.ml. *) let params_ty = List.map - (fun k -> - C.extended_machtype_of_kind k - |> C.Extended_machtype.change_tagged_int_to_val) - (Flambda_arity.to_list (Code_metadata.params_arity info)) + (fun ks -> + List.map + (fun k -> + C.extended_machtype_of_kind k + |> C.Extended_machtype.change_tagged_int_to_val) + ks + |> Array.concat) + (Flambda_arity.unarize_per_parameter (Code_metadata.params_arity info)) in let result_machtype = C.extended_machtype_of_return_arity (Code_metadata.result_arity info) diff --git a/middle_end/flambda2/to_cmm/to_cmm_shared.ml b/middle_end/flambda2/to_cmm/to_cmm_shared.ml index 9b6a239d885..36d4ea51cbe 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_shared.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_shared.ml @@ -246,10 +246,11 @@ let make_update env res dbg kind ~symbol var ~index ~prev_updates = in env, res, Some update -let check_arity arity args = Flambda_arity.cardinal arity = List.length args +let check_arity arity args = + Flambda_arity.cardinal_unarized arity = List.length args let extended_machtype_of_return_arity arity = - match Flambda_arity.to_list arity with + match Flambda_arity.unarized_components arity with | [] -> (* Functions that never return have arity 0. In that case, we use the most restrictive machtype to ensure that the return value of the function is diff --git a/middle_end/flambda2/to_cmm/to_cmm_shared.mli b/middle_end/flambda2/to_cmm/to_cmm_shared.mli index 72fcbcad728..ca901edff96 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_shared.mli +++ b/middle_end/flambda2/to_cmm/to_cmm_shared.mli @@ -98,7 +98,7 @@ val make_update : prev_updates:To_cmm_env.expr_with_info option -> To_cmm_env.t * To_cmm_result.t * To_cmm_env.expr_with_info option -val check_arity : Flambda_arity.t -> _ list -> bool +val check_arity : _ Flambda_arity.t -> _ list -> bool val extended_machtype_of_return_arity : - Flambda_arity.t -> Cmm_helpers.Extended_machtype.t + [`Unarized] Flambda_arity.t -> Cmm_helpers.Extended_machtype.t diff --git a/middle_end/flambda2/types/flambda2_types.mli b/middle_end/flambda2/types/flambda2_types.mli index 783e4096d5a..5d4e056ac12 100644 --- a/middle_end/flambda2/types/flambda2_types.mli +++ b/middle_end/flambda2/types/flambda2_types.mli @@ -23,7 +23,7 @@ type flambda_type = t val print : Format.formatter -> t -> unit -val arity_of_list : t list -> Flambda_arity.t +val arity_of_list : t list -> [`Unarized] Flambda_arity.t val apply_renaming : t -> Renaming.t -> t @@ -515,10 +515,10 @@ val kind : t -> Flambda_kind.t val get_alias_exn : t -> Simple.t (** For each of the kinds in an arity, create an "unknown" type. *) -val unknown_types_from_arity : Flambda_arity.t -> t list +val unknown_types_from_arity : [`Unarized] Flambda_arity.t -> t list (** For each of the kinds in an arity, create an "bottom" type. *) -val bottom_types_from_arity : Flambda_arity.t -> t list +val bottom_types_from_arity : [`Complex] Flambda_arity.t -> t list (** Whether the given type says that a term of that type can never be constructed (in other words, it is [Invalid]). *) diff --git a/middle_end/flambda2/types/grammar/more_type_creators.ml b/middle_end/flambda2/types/grammar/more_type_creators.ml index 298f030fa7b..1dd88dd6a1a 100644 --- a/middle_end/flambda2/types/grammar/more_type_creators.ml +++ b/middle_end/flambda2/types/grammar/more_type_creators.ml @@ -275,7 +275,7 @@ let check_equation name ty = Name.print name TG.print ty let arity_of_list ts = - Flambda_arity.create + Flambda_arity.create_singletons (List.map (fun ty -> Flambda_kind.With_subkind.anything (TG.kind ty)) ts) let rec unknown_with_subkind ?(alloc_mode = Alloc_mode.For_types.unknown ()) @@ -328,7 +328,9 @@ let rec unknown_with_subkind ?(alloc_mode = Alloc_mode.For_types.unknown ()) let bottom_with_subkind kind = bottom (Flambda_kind.With_subkind.kind kind) let unknown_types_from_arity arity = - List.map (fun kind -> unknown_with_subkind kind) (Flambda_arity.to_list arity) + List.map + (unknown_with_subkind ?alloc_mode:None) + (Flambda_arity.unarized_components arity) let bottom_types_from_arity arity = - List.map bottom_with_subkind (Flambda_arity.to_list arity) + List.map bottom_with_subkind (Flambda_arity.unarize arity) diff --git a/middle_end/flambda2/types/grammar/more_type_creators.mli b/middle_end/flambda2/types/grammar/more_type_creators.mli index 46e6df57046..65ca6e6fdb6 100644 --- a/middle_end/flambda2/types/grammar/more_type_creators.mli +++ b/middle_end/flambda2/types/grammar/more_type_creators.mli @@ -141,7 +141,7 @@ val is_alias_of_name : Type_grammar.t -> Name.t -> bool val check_equation : Name.t -> Type_grammar.t -> unit -val arity_of_list : Type_grammar.t list -> Flambda_arity.t +val arity_of_list : Type_grammar.t list -> [`Unarized] Flambda_arity.t val unknown_with_subkind : ?alloc_mode:Alloc_mode.For_types.t -> @@ -149,7 +149,8 @@ val unknown_with_subkind : Type_grammar.t (** For each of the kinds in an arity, create an "unknown" type. *) -val unknown_types_from_arity : Flambda_arity.t -> Type_grammar.t list +val unknown_types_from_arity : + [`Unarized] Flambda_arity.t -> Type_grammar.t list (** For each of the kinds in an arity, create an "bottom" type. *) -val bottom_types_from_arity : Flambda_arity.t -> Type_grammar.t list +val bottom_types_from_arity : [`Complex] Flambda_arity.t -> Type_grammar.t list diff --git a/middle_end/flambda2/ui/flambda_colours.ml b/middle_end/flambda2/ui/flambda_colours.ml index d4f206afac2..c40731f71ce 100644 --- a/middle_end/flambda2/ui/flambda_colours.ml +++ b/middle_end/flambda2/ui/flambda_colours.ml @@ -102,6 +102,8 @@ let prim_neither ppf = push ~fg:130 ppf let naked_number ppf = push ~fg:70 ppf +let unboxed_product ppf = push ~fg:198 ppf + let tagged_immediate ppf = push ~fg:70 ppf let constructor ppf = push ~fg:69 ppf diff --git a/middle_end/flambda2/ui/flambda_colours.mli b/middle_end/flambda2/ui/flambda_colours.mli index 200bb0eae61..367fcc4b321 100644 --- a/middle_end/flambda2/ui/flambda_colours.mli +++ b/middle_end/flambda2/ui/flambda_colours.mli @@ -92,4 +92,6 @@ val each_file : directive val lambda : directive +val unboxed_product : directive + val without_colours : f:(unit -> 'a) -> 'a diff --git a/middle_end/internal_variable_names.ml b/middle_end/internal_variable_names.ml index 4fb6290a49b..536c9a627ed 100644 --- a/middle_end/internal_variable_names.ml +++ b/middle_end/internal_variable_names.ml @@ -314,6 +314,10 @@ let punbox_int = "Punbox_int" let pbox_int = "Pbox_int" let punbox_int_arg = "Punbox_int_arg" let pbox_int_arg = "Pbox_int_arg" +let pmake_unboxed_product = "Pmake_unboxed_product" +let punboxed_product_field = "Punboxed_product_field" +let pmake_unboxed_product_arg = "Pmake_unboxed_product_arg" +let punboxed_product_field_arg = "Punboxed_product_field_arg" let anon_fn_with_loc (sloc: Lambda.scoped_location) = let loc = Debuginfo.Scoped_location.to_location sloc in @@ -439,6 +443,8 @@ let of_primitive : Lambda.primitive -> string = function | Pbox_int _ -> pbox_int | Parray_of_iarray -> parray_of_iarray | Parray_to_iarray -> parray_to_iarray + | Pmake_unboxed_product _ -> pmake_unboxed_product + | Punboxed_product_field _ -> punboxed_product_field let of_primitive_arg : Lambda.primitive -> string = function | Pbytes_of_string -> pbytes_of_string_arg @@ -553,3 +559,5 @@ let of_primitive_arg : Lambda.primitive -> string = function | Pbox_int _ -> pbox_int_arg | Parray_of_iarray -> parray_of_iarray_arg | Parray_to_iarray -> parray_to_iarray_arg + | Pmake_unboxed_product _ -> pmake_unboxed_product_arg + | Punboxed_product_field _ -> punboxed_product_field_arg diff --git a/middle_end/printclambda.ml b/middle_end/printclambda.ml index 984c31715c9..2e507bac49d 100644 --- a/middle_end/printclambda.ml +++ b/middle_end/printclambda.ml @@ -60,6 +60,10 @@ let layout (layout : Lambda.layout) = | Punboxed_int Pint32 -> ":unboxed_int32" | Punboxed_int Pint64 -> ":unboxed_int64" | Punboxed_int Pnativeint -> ":unboxed_nativeint" + | Punboxed_product layouts -> + Format.asprintf ":unboxed_product(%a)" + (Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ", ") + Printlambda.layout) layouts let rec structured_constant ppf = function | Uconst_float x -> fprintf ppf "%F" x diff --git a/middle_end/printclambda_primitives.ml b/middle_end/printclambda_primitives.ml index f8762b18c4f..de7b6d694e7 100644 --- a/middle_end/printclambda_primitives.ml +++ b/middle_end/printclambda_primitives.ml @@ -235,3 +235,17 @@ let primitive ppf (prim:Clambda_primitives.primitive) = | Pbox_int (bi, m) -> fprintf ppf "box_%s.%s" (boxed_integer_name bi) (alloc_kind m) | Punbox_int bi -> fprintf ppf "unbox_%s" (boxed_integer_name bi) + | Pmake_unboxed_product layouts -> + fprintf ppf "make_unboxed_product(@[%a@])" + (Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ") + Printlambda.layout) + layouts + | Punboxed_product_field (field, layouts) -> + fprintf ppf "unboxed_product_field(@[%a@]) %i" + (Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ") + Printlambda.layout) + layouts + field + diff --git a/middle_end/semantics_of_primitives.ml b/middle_end/semantics_of_primitives.ml index d1ffb1c0ebf..c63d36db751 100644 --- a/middle_end/semantics_of_primitives.ml +++ b/middle_end/semantics_of_primitives.ml @@ -83,6 +83,8 @@ let for_primitive (prim : Clambda_primitives.primitive) = | Poffsetint _ -> No_effects, No_coeffects | Poffsetref _ -> Arbitrary_effects, Has_coeffects | Punbox_float | Punbox_int _ + | Pmake_unboxed_product _ + | Punboxed_product_field _ | Pintoffloat | Pfloatcomp _ -> No_effects, No_coeffects | Pbox_float m | Pbox_int (_, m) @@ -213,6 +215,8 @@ let may_locally_allocate (prim:Clambda_primitives.primitive) : bool = | Poffsetint _ -> false | Poffsetref _ -> false | Punbox_float | Punbox_int _ + | Pmake_unboxed_product _ + | Punboxed_product_field _ | Pintoffloat | Pfloatcomp _ -> false | Pbox_float m | Pbox_int (_, m) diff --git a/native_toplevel/opttopdirs.ml b/native_toplevel/opttopdirs.ml index 7d347603a91..a048a3097cb 100644 --- a/native_toplevel/opttopdirs.ml +++ b/native_toplevel/opttopdirs.ml @@ -138,7 +138,7 @@ let match_printer_type ppf desc typename = raise Exit in Ctype.begin_def(); - let ty_arg = Ctype.newvar Layouts.Layout.value in + let ty_arg = Ctype.newvar (Layouts.Layout.value ~why:Debug_printer_argument) in Ctype.unify !toplevel_env (Ctype.newconstr printer_type [ty_arg]) (Ctype.instance desc.val_type); diff --git a/ocaml/asmcomp/cmm_helpers.ml b/ocaml/asmcomp/cmm_helpers.ml index 93fdc4bdc83..b3e6d17a37e 100644 --- a/ocaml/asmcomp/cmm_helpers.ml +++ b/ocaml/asmcomp/cmm_helpers.ml @@ -3276,6 +3276,6 @@ let kind_of_layout (layout : Lambda.layout) = | Pvalue Pfloatval -> Boxed_float | Pvalue (Pboxedintval bi) -> Boxed_integer bi | Pvalue (Pgenval | Pintval | Pvariant _ | Parrayval _) - | Ptop | Pbottom | Punboxed_float | Punboxed_int _ -> Any + | Ptop | Pbottom | Punboxed_float | Punboxed_int _ | Punboxed_product _ -> Any let make_tuple l = match l with [e] -> e | _ -> Ctuple l diff --git a/ocaml/asmcomp/cmmgen.ml b/ocaml/asmcomp/cmmgen.ml index 03eb963d864..324684047ce 100644 --- a/ocaml/asmcomp/cmmgen.ml +++ b/ocaml/asmcomp/cmmgen.ml @@ -124,6 +124,7 @@ let get_field env layout ptr n dbg = | Pvalue Pintval | Punboxed_int _ -> Word_int | Pvalue _ -> Word_val | Punboxed_float -> Double + | Punboxed_product _ -> Misc.fatal_error "TBD" | Ptop -> Misc.fatal_errorf "get_field with Ptop: %a" Debuginfo.print_compact dbg | Pbottom -> @@ -1294,6 +1295,7 @@ and transl_let env str (layout : Lambda.layout) id exp transl_body = end | Pvalue kind -> transl_let_value env str kind id exp transl_body + | Punboxed_product _ -> Misc.fatal_error "TBD" and make_catch (kind : Cmm.kind_for_unboxing) ncatch body handler dbg = match body with | Cexit (nexit,[]) when nexit=ncatch -> handler diff --git a/ocaml/boot/ocamlc b/ocaml/boot/ocamlc index 6e3cbcd1798..6620116ad3a 100755 Binary files a/ocaml/boot/ocamlc and b/ocaml/boot/ocamlc differ diff --git a/ocaml/boot/ocamllex b/ocaml/boot/ocamllex index 1c22ad1473c..0fe92796177 100755 Binary files a/ocaml/boot/ocamllex and b/ocaml/boot/ocamllex differ diff --git a/ocaml/bytecomp/bytegen.ml b/ocaml/bytecomp/bytegen.ml index d2268155244..67b83a08a7c 100644 --- a/ocaml/bytecomp/bytegen.ml +++ b/ocaml/bytecomp/bytegen.ml @@ -119,6 +119,7 @@ let preserve_tailcall_for_prim = function | Pmakeblock _ | Pmakefloatblock _ | Pfield _ | Pfield_computed _ | Psetfield _ | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Pduprecord _ + | Pmake_unboxed_product _ | Punboxed_product_field _ | Pccall _ | Praise _ | Pnot | Pnegint | Paddint | Psubint | Pmulint | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint | Pintcomp _ | Poffsetint _ | Poffsetref _ | Pintoffloat @@ -539,6 +540,7 @@ let comp_primitive p args = | Pmakefloatblock _ | Pprobe_is_enabled _ | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _ + | Pmake_unboxed_product _ | Punboxed_product_field _ -> fatal_error "Bytegen.comp_primitive" diff --git a/ocaml/debugger/loadprinter.ml b/ocaml/debugger/loadprinter.ml index 94fd2a7fbfe..d48f7abf40d 100644 --- a/ocaml/debugger/loadprinter.ml +++ b/ocaml/debugger/loadprinter.ml @@ -112,7 +112,7 @@ let match_printer_type desc typename = raise (Error(Unbound_identifier(Ldot(Lident "Topdirs", typename)))) in Ctype.begin_def(); - let ty_arg = Ctype.newvar Layout.any in + let ty_arg = Ctype.newvar Layout.(value ~why:Debug_printer_argument) in Ctype.unify Env.initial_safe_string (Ctype.newconstr printer_type [ty_arg]) (Ctype.instance desc.val_type); diff --git a/ocaml/lambda/lambda.ml b/ocaml/lambda/lambda.ml index 09029793cbc..6436411cd15 100644 --- a/ocaml/lambda/lambda.ml +++ b/ocaml/lambda/lambda.ml @@ -147,6 +147,9 @@ type primitive = | Pfloatfield of int * field_read_semantics * alloc_mode | Psetfloatfield of int * initialization_or_assignment | Pduprecord of Types.record_representation * int + (* Unboxed products *) + | Pmake_unboxed_product of layout list + | Punboxed_product_field of int * layout list (* Force lazy values *) (* External call *) | Pccall of Primitive.description @@ -266,6 +269,7 @@ and layout = | Pvalue of value_kind | Punboxed_float | Punboxed_int of boxed_integer + | Punboxed_product of layout list | Pbottom and block_shape = @@ -334,7 +338,7 @@ let equal_layout x y = | Pbottom, Pbottom -> true | _, _ -> false -let compatible_layout x y = +let rec compatible_layout x y = match x, y with | Pbottom, _ | _, Pbottom -> true @@ -342,9 +346,13 @@ let compatible_layout x y = | Punboxed_float, Punboxed_float -> true | Punboxed_int bi1, Punboxed_int bi2 -> equal_boxed_integer bi1 bi2 + | Punboxed_product layouts1, Punboxed_product layouts2 -> + List.compare_lengths layouts1 layouts2 = 0 + && List.for_all2 compatible_layout layouts1 layouts2 | Ptop, Ptop -> true | Ptop, _ | _, Ptop -> false - | (Pvalue _ | Punboxed_float | Punboxed_int _), _ -> false + | (Pvalue _ | Punboxed_float | Punboxed_int _ | Punboxed_product _), _ -> + false let must_be_value layout = match layout with @@ -632,6 +640,7 @@ let layout_lazy = Pvalue Pgenval let layout_lazy_contents = Pvalue Pgenval let layout_any_value = Pvalue Pgenval let layout_letrec = layout_any_value +let layout_unboxed_product layouts = Punboxed_product layouts (* CR ncourant: use [Ptop] or remove this as soon as possible. *) let layout_top = layout_any_value @@ -1327,6 +1336,7 @@ let primitive_may_allocate : primitive -> alloc_mode option = function | Pfloatfield (_, _, m) -> Some m | Psetfloatfield _ -> None | Pduprecord _ -> Some alloc_heap + | Pmake_unboxed_product _ | Punboxed_product_field _ -> None | Pccall p -> if not p.prim_alloc then None else begin match p.prim_native_repr_res with @@ -1414,6 +1424,7 @@ let structured_constant_layout = function | Const_float_array _ | Const_float_block _ -> Pvalue (Parrayval Pfloatarray) let primitive_result_layout (p : primitive) = + assert !Clflags.native_code; match p with | Popaque layout | Pobj_magic layout -> layout | Pbytes_to_string | Pbytes_of_string -> layout_string @@ -1426,13 +1437,18 @@ let primitive_result_layout (p : primitive) = | Pmakeblock _ | Pmakefloatblock _ | Pmakearray _ | Pduprecord _ | Pduparray _ | Pbigarraydim _ | Pobj_dup -> layout_block | Pfield _ | Pfield_computed _ -> layout_field + | Punboxed_product_field (field, layouts) -> (Array.of_list layouts).(field) + | Pmake_unboxed_product layouts -> layout_unboxed_product layouts | Pfloatfield _ | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _ | Pbox_float _ -> layout_float | Punbox_float -> Punboxed_float - | Pccall _p -> - (* CR ncourant: use native_repr *) + | Pccall { prim_native_repr_res = _, Untagged_int; _} -> layout_int + | Pccall { prim_native_repr_res = _, Unboxed_float; _} -> layout_float + | Pccall { prim_native_repr_res = _, Same_as_ocaml_repr; _} -> layout_any_value + | Pccall { prim_native_repr_res = _, Unboxed_integer bi; _} -> + layout_boxedint bi | Praise _ -> layout_bottom | Psequor | Psequand | Pnot | Pnegint | Paddint | Psubint | Pmulint diff --git a/ocaml/lambda/lambda.mli b/ocaml/lambda/lambda.mli index f368fae0720..5934589522c 100644 --- a/ocaml/lambda/lambda.mli +++ b/ocaml/lambda/lambda.mli @@ -95,6 +95,9 @@ type primitive = | Pfloatfield of int * field_read_semantics * alloc_mode | Psetfloatfield of int * initialization_or_assignment | Pduprecord of Types.record_representation * int + (* Unboxed products *) + | Pmake_unboxed_product of layout list + | Punboxed_product_field of int * (layout list) (* External call *) | Pccall of Primitive.description (* Exceptions *) @@ -227,6 +230,7 @@ and layout = | Pvalue of value_kind | Punboxed_float | Punboxed_int of boxed_integer + | Punboxed_product of layout list | Pbottom and block_shape = @@ -522,6 +526,8 @@ val layout_any_value : layout (* A layout that is Pgenval because it is bound by a letrec *) val layout_letrec : layout +val layout_unboxed_product : layout list -> layout + val layout_top : layout val layout_bottom : layout diff --git a/ocaml/lambda/matching.ml b/ocaml/lambda/matching.ml index 04df1ac5f4e..13ef33d0fa3 100644 --- a/ocaml/lambda/matching.ml +++ b/ocaml/lambda/matching.ml @@ -100,7 +100,7 @@ open Printpat module Scoped_location = Debuginfo.Scoped_location type error = - Non_value_layout of Layout.Violation.violation + Non_value_layout of Layout.Violation.t exception Error of Location.t * error @@ -109,8 +109,8 @@ let dbg = false (* CR layouts v2: When we're ready to allow non-values, these can be deleted or changed to check for void. *) let layout_must_be_value loc layout = - match Layout.(sub layout value) with - | Ok () -> () + match Layout.(sub layout (value ~why:V1_safety_check)) with + | Ok _ -> () | Error e -> raise (Error (loc, Non_value_layout e)) (* diff --git a/ocaml/lambda/printlambda.ml b/ocaml/lambda/printlambda.ml index 3cb44d1579c..23e4b76c543 100644 --- a/ocaml/lambda/printlambda.ml +++ b/ocaml/lambda/printlambda.ml @@ -77,6 +77,9 @@ let variant_kind print_contents ppf ~consts ~non_consts = )) non_consts +let unboxed_product_debug () = + match Sys.getenv "DEBUG" with exception Not_found -> false | _ -> true + let rec value_kind ppf = function | Pgenval -> () | Pintval -> fprintf ppf "[int]" @@ -86,8 +89,10 @@ let rec value_kind ppf = function | Pvariant { consts; non_consts; } -> variant_kind value_kind' ppf ~consts ~non_consts +(* CR mshinwell: we need to work out how to fix these printers properly *) + and value_kind' ppf = function - | Pgenval -> fprintf ppf "*" + | Pgenval -> fprintf ppf (if unboxed_product_debug () then "[val]" else "*") | Pintval -> fprintf ppf "[int]" | Pfloatval -> fprintf ppf "[float]" | Parrayval elt_kind -> fprintf ppf "[%sarray]" (array_kind elt_kind) @@ -95,13 +100,18 @@ and value_kind' ppf = function | Pvariant { consts; non_consts; } -> variant_kind value_kind' ppf ~consts ~non_consts -let layout ppf layout = - match layout with - | Pvalue k -> value_kind ppf k +let rec layout ppf layout_ = + match layout_ with + | Pvalue k -> + (if unboxed_product_debug () then value_kind' else value_kind) ppf k | Ptop -> fprintf ppf "[top]" | Pbottom -> fprintf ppf "[bottom]" | Punboxed_float -> fprintf ppf "[unboxed_float]" | Punboxed_int bi -> fprintf ppf "[unboxed_%s]" (boxed_integer_name bi) + | Punboxed_product layouts -> + fprintf ppf "[%a]" + (pp_print_list ~pp_sep:(fun ppf () -> pp_print_string ppf " * ") layout) + layouts let return_kind ppf (mode, kind) = let smode = alloc_mode mode in @@ -117,6 +127,7 @@ let return_kind ppf (mode, kind) = variant_kind value_kind' ppf ~consts ~non_consts | Punboxed_float -> fprintf ppf ": unboxed_float@ " | Punboxed_int bi -> fprintf ppf ": unboxed_%s@ " (boxed_integer_name bi) + | Punboxed_product _ -> fprintf ppf ": %a" layout kind | Ptop -> fprintf ppf ": top@ " | Pbottom -> fprintf ppf ": bottom@ " @@ -291,6 +302,12 @@ let primitive ppf = function in fprintf ppf "setfloatfield%s %i" init n | Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size + | Pmake_unboxed_product layouts -> + fprintf ppf "make_unboxed_product [%a]" + (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf " * ") layout) layouts + | Punboxed_product_field (n, layouts) -> + fprintf ppf "unboxed_product_field %d [%a]" n + (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf " * ") layout) layouts | Pccall p -> fprintf ppf "%s" p.prim_name | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k) | Psequand -> fprintf ppf "&&" @@ -472,6 +489,8 @@ let name_of_primitive = function | Pfloatfield _ -> "Pfloatfield" | Psetfloatfield _ -> "Psetfloatfield" | Pduprecord _ -> "Pduprecord" + | Pmake_unboxed_product _ -> "Pmake_unboxed_product" + | Punboxed_product_field _ -> "Punboxed_product_field" | Pccall _ -> "Pccall" | Praise _ -> "Praise" | Psequand -> "Psequand" diff --git a/ocaml/lambda/tmc.ml b/ocaml/lambda/tmc.ml index 3d549135740..1669460dc64 100644 --- a/ocaml/lambda/tmc.ml +++ b/ocaml/lambda/tmc.ml @@ -896,6 +896,9 @@ let rec choice ctx t = (* we don't handle all-float records *) | Pmakefloatblock _ + (* nor unboxed products *) + | Pmake_unboxed_product _ | Punboxed_product_field _ + | Pobj_dup | Pobj_magic _ | Pprobe_is_enabled _ diff --git a/ocaml/lambda/translcore.ml b/ocaml/lambda/translcore.ml index e4e0be49cdc..87823277582 100644 --- a/ocaml/lambda/translcore.ml +++ b/ocaml/lambda/translcore.ml @@ -31,7 +31,7 @@ type error = Free_super_var | Unreachable_reached | Bad_probe_layout of Ident.t - | Non_value_layout of Layout.Violation.violation + | Non_value_layout of Layout.Violation.t exception Error of Location.t * error @@ -39,14 +39,16 @@ let use_dup_for_constant_mutable_arrays_bigger_than = 4 (* CR layouts v2: When we're ready to allow non-values, these can be deleted or changed to check for void. *) -let sort_must_be_value loc sort = +let sort_must_be_value ~why loc sort = if not Sort.(equate sort value) then - let violation = Layout.(Violation.not_a_sublayout (of_sort sort) value) in + let violation = Layout.(Violation.of_ (Not_a_sublayout + (of_sort ~why sort, + value ~why:V1_safety_check))) in raise (Error (loc, Non_value_layout violation)) let layout_must_be_value loc layout = - match Layout.(sub layout value) with - | Ok () -> () + match Layout.(sub layout (value ~why:V1_safety_check)) with + | Ok _ -> () | Error e -> raise (Error (loc, Non_value_layout e)) (* CR layouts v2: In the places where this is used, we want to allow any (the @@ -61,9 +63,10 @@ let layout_must_be_value loc layout = *) let layout_must_not_be_void loc layout = Layout.default_to_value layout; - match Layout.(sub layout void) with - | Ok () -> - let violation = Layout.(Violation.not_a_sublayout layout value) in + match Layout.(sub layout (void ~why:V1_safety_check)) with + | Ok _ -> + let violation = Layout.(Violation.of_ (Not_a_sublayout + (layout, value ~why:V1_safety_check))) in raise (Error (loc, Non_value_layout violation)) | Error _ -> () @@ -907,8 +910,9 @@ and transl_exp0 ~in_new_scope ~scopes e = with | {val_type; _} -> begin match - Ctype.check_type_layout ~reason:(Fixed_layout Probe) - e.exp_env (Ctype.correct_levels val_type) Layout.value + Ctype.check_type_layout + e.exp_env (Ctype.correct_levels val_type) + (Layout.value ~why:Probe) with | Ok _ -> () | Error _ -> raise (Error (e.exp_loc, Bad_probe_layout id)) @@ -1354,7 +1358,7 @@ and transl_let ~scopes ?(add_regions=false) ?(in_structure=false) :: rem -> (* CR layouts v2: allow non-values. Either remove this or replace with void-specific sanity check. *) - sort_must_be_value expr.exp_loc sort; + sort_must_be_value ~why:Let_binding expr.exp_loc sort; let lam = transl_bound_exp ~scopes ~in_structure pat expr in let lam = Translattribute.add_function_attributes lam vb_loc attr in let lam = if add_regions then maybe_region_exp expr lam else lam in @@ -1374,7 +1378,7 @@ and transl_let ~scopes ?(add_regions=false) ?(in_structure=false) {vb_expr=expr; vb_sort; vb_attributes; vb_loc; vb_pat} id = (* CR layouts v2: allow non-values. Either remove this or replace with void-specific sanity check. *) - sort_must_be_value expr.exp_loc vb_sort; + sort_must_be_value ~why:Let_binding expr.exp_loc vb_sort; let lam = transl_bound_exp ~scopes ~in_structure vb_pat expr in let lam = Translattribute.add_function_attributes lam vb_loc vb_attributes diff --git a/ocaml/lambda/translcore.mli b/ocaml/lambda/translcore.mli index 7d55178841f..d78490bdba6 100644 --- a/ocaml/lambda/translcore.mli +++ b/ocaml/lambda/translcore.mli @@ -50,7 +50,7 @@ type error = Free_super_var | Unreachable_reached | Bad_probe_layout of Ident.t - | Non_value_layout of Layouts.Layout.Violation.violation + | Non_value_layout of Layouts.Layout.Violation.t exception Error of Location.t * error diff --git a/ocaml/lambda/translmod.ml b/ocaml/lambda/translmod.ml index 0de6656ad4c..ccbcfd1a199 100644 --- a/ocaml/lambda/translmod.ml +++ b/ocaml/lambda/translmod.ml @@ -39,7 +39,7 @@ type unsafe_info = type error = Circular_dependency of (Ident.t * unsafe_info) list | Conflicting_inline_attributes -| Non_value_layout of type_expr * Layout.Violation.violation +| Non_value_layout of type_expr * Layout.Violation.t exception Error of Location.t * error @@ -55,9 +55,13 @@ exception Error of Location.t * error When this sanity check is removed, consider whether it must be replaced with some defaulting. *) let sort_must_not_be_void loc ty sort = - let layout = Layout.of_sort sort in - if Layout.is_void layout then - let violation = Layout.(Violation.not_a_sublayout layout value) in + if Sort.is_void_defaulting sort then + let violation = + Layout.(Violation.of_ + (Not_a_sublayout + (Layout.of_sort ~why:V1_safety_check sort, + value ~why:V1_safety_check))) + in raise (Error (loc, Non_value_layout (ty, violation))) let cons_opt x_opt xs = diff --git a/ocaml/lambda/translmod.mli b/ocaml/lambda/translmod.mli index 423b75b9aaa..9322a8027fe 100644 --- a/ocaml/lambda/translmod.mli +++ b/ocaml/lambda/translmod.mli @@ -53,7 +53,7 @@ type unsafe_info = type error = Circular_dependency of (Ident.t * unsafe_info) list | Conflicting_inline_attributes -| Non_value_layout of Types.type_expr * Layouts.Layout.Violation.violation +| Non_value_layout of Types.type_expr * Layouts.Layout.Violation.t exception Error of Location.t * error diff --git a/ocaml/lambda/translprim.ml b/ocaml/lambda/translprim.ml index 195f2e9f832..ba0bac42184 100644 --- a/ocaml/lambda/translprim.ml +++ b/ocaml/lambda/translprim.ml @@ -93,6 +93,7 @@ type prim = | Identity | Apply of Lambda.region_close * Lambda.layout | Revapply of Lambda.region_close * Lambda.layout + | Void let units_with_used_primitives = Hashtbl.create 7 let add_used_primitive loc env path = @@ -133,6 +134,14 @@ let to_modify_mode ~poly = function | None -> assert false | Some mode -> transl_modify_mode mode +let layout_unboxed_pair_of_values = + Punboxed_product [Pvalue Pgenval; Pvalue Pgenval] + +let two_unboxed_pairs_of_values = + [ layout_unboxed_pair_of_values; + layout_unboxed_pair_of_values; + ] + let lookup_primitive loc poly pos p = let mode = to_alloc_mode ~poly p.prim_native_repr_res in let arg_modes = List.map (to_modify_mode ~poly) p.prim_native_repr_args in @@ -401,6 +410,40 @@ let lookup_primitive loc poly pos p = | "%obj_magic" -> Primitive(Pobj_magic Lambda.layout_any_value, 1) | "%array_to_iarray" -> Primitive (Parray_to_iarray, 1) | "%array_of_iarray" -> Primitive (Parray_of_iarray, 1) + (* unboxed pairs of void *) + | "%make_unboxed_pair_o_o" -> + Primitive(Pmake_unboxed_product [Punboxed_product []; Punboxed_product []], 2) + | "%unboxed_pair_field_0_o_o" -> + Primitive(Punboxed_product_field (0, [Punboxed_product []; Punboxed_product []]), 1) + | "%unboxed_pair_field_1_o_o" -> + Primitive(Punboxed_product_field (1, [Punboxed_product []; Punboxed_product []]), 1) + (* unboxed pairs of values *) + | "%make_unboxed_pair_v_v" -> + Primitive(Pmake_unboxed_product [Pvalue Pgenval; Pvalue Pgenval], 2) + | "%unboxed_pair_field_0_v_v" -> + Primitive(Punboxed_product_field (0, [Pvalue Pgenval; Pvalue Pgenval]), 1) + | "%unboxed_pair_field_1_v_v" -> + Primitive(Punboxed_product_field (1, [Pvalue Pgenval; Pvalue Pgenval]), 1) + (* unboxed pairs of immediates *) + | "%make_unboxed_pair_i_i" -> + Primitive(Pmake_unboxed_product [Pvalue Pintval; Pvalue Pintval], 2) + | "%unboxed_pair_field_0_i_i" -> + Primitive(Punboxed_product_field (0, [Pvalue Pintval; Pvalue Pintval]), 1) + | "%unboxed_pair_field_1_i_i" -> + Primitive(Punboxed_product_field (1, [Pvalue Pintval; Pvalue Pintval]), 1) + (* unboxed pairs of (unboxed pairs of values) *) + | "%make_unboxed_pair_vup_vup" -> + Primitive(Pmake_unboxed_product [layout_unboxed_pair_of_values; layout_unboxed_pair_of_values], 2) + | "%unboxed_pair_field_0_vup_vup" -> + Primitive(Punboxed_product_field (0, two_unboxed_pairs_of_values), 1) + | "%unboxed_pair_field_1_vup_vup" -> + Primitive(Punboxed_product_field (1, two_unboxed_pairs_of_values), 1) + (* unboxed triples (void, int, void) *) + | "%make_unboxed_triple_o_i_o" -> + Primitive(Pmake_unboxed_product [Punboxed_product []; Pvalue Pintval; Punboxed_product []], 3) + (* void is special as the external is declared to have one parameter + but the primitive takes zero arguments *) + | "%void" -> Void | s when String.length s > 0 && s.[0] = '%' -> raise(Error(loc, Unknown_builtin_primitive s)) | _ -> External p @@ -767,6 +810,7 @@ let lambda_of_prim prim_name prim loc args arg_exps = ap_region_close = pos; ap_mode = alloc_heap; } + | Void, _ -> Lprim (Pmake_unboxed_product [], [], loc) | (Raise _ | Raise_with_backtrace | Lazy_force _ | Loc _ | Primitive _ | Sys_argv | Comparison _ | Send _ | Send_self _ | Send_cache _ | Frame_pointers | Identity @@ -795,6 +839,7 @@ let check_primitive_arity loc p = | Frame_pointers -> p.prim_arity = 0 | Identity -> p.prim_arity = 1 | Apply _ | Revapply _ -> p.prim_arity = 2 + | Void -> true in if not ok then raise(Error(loc, Wrong_arity_builtin_primitive p.prim_name)) @@ -882,6 +927,7 @@ let lambda_primitive_needs_event_after = function | Parray_to_iarray | Parray_of_iarray | Pignore | Psetglobal _ | Pgetglobal _ | Pgetpredef _ | Pmakeblock _ | Pmakefloatblock _ + | Pmake_unboxed_product _ | Punboxed_product_field _ | Pfield _ | Pfield_computed _ | Psetfield _ | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Praise _ | Psequor | Psequand | Pnot | Pnegint | Paddint | Psubint | Pmulint @@ -903,7 +949,7 @@ 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 | Void -> false let transl_primitive_application loc p env ty mode path exp args arg_exps pos = let prim = diff --git a/ocaml/middle_end/clambda_primitives.ml b/ocaml/middle_end/clambda_primitives.ml index 77e66745305..b0b731993c7 100644 --- a/ocaml/middle_end/clambda_primitives.ml +++ b/ocaml/middle_end/clambda_primitives.ml @@ -150,6 +150,7 @@ and layout = Lambda.layout = | Pvalue of value_kind | Punboxed_float | Punboxed_int of boxed_integer + | Punboxed_product of layout list | Pbottom and block_shape = Lambda.block_shape diff --git a/ocaml/middle_end/clambda_primitives.mli b/ocaml/middle_end/clambda_primitives.mli index e71b17c4c85..5e3ddfd0765 100644 --- a/ocaml/middle_end/clambda_primitives.mli +++ b/ocaml/middle_end/clambda_primitives.mli @@ -153,6 +153,7 @@ and layout = Lambda.layout = | Pvalue of value_kind | Punboxed_float | Punboxed_int of boxed_integer + | Punboxed_product of layout list | Pbottom and block_shape = Lambda.block_shape diff --git a/ocaml/middle_end/closure/closure.ml b/ocaml/middle_end/closure/closure.ml index a4c352d03fc..26f774f8395 100644 --- a/ocaml/middle_end/closure/closure.ml +++ b/ocaml/middle_end/closure/closure.ml @@ -65,6 +65,7 @@ let is_gc_ignorable kind = | Punboxed_int _ -> true | Pvalue Pintval -> true | Pvalue (Pgenval | Pfloatval | Pboxedintval _ | Pvariant _ | Parrayval _) -> false + | Punboxed_product _ -> Misc.fatal_error "TBD" let split_closure_fv kinds fv = List.fold_right (fun id (not_scanned, scanned) -> diff --git a/ocaml/middle_end/convert_primitives.ml b/ocaml/middle_end/convert_primitives.ml index 541af7ecf86..9180f67f359 100644 --- a/ocaml/middle_end/convert_primitives.ml +++ b/ocaml/middle_end/convert_primitives.ml @@ -38,6 +38,8 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive = | Psetfloatfield (field, init_or_assign) -> Psetfloatfield (field, init_or_assign) | Pduprecord (repr, size) -> Pduprecord (repr, size) + | Pmake_unboxed_product _ + | Punboxed_product_field _ -> Misc.fatal_error "TODO" | Pccall prim -> Pccall prim | Praise kind -> Praise kind | Psequand -> Psequand diff --git a/ocaml/middle_end/flambda/closure_offsets.ml b/ocaml/middle_end/flambda/closure_offsets.ml index cfb1791786d..11f071656ec 100644 --- a/ocaml/middle_end/flambda/closure_offsets.ml +++ b/ocaml/middle_end/flambda/closure_offsets.ml @@ -80,7 +80,8 @@ let add_closure_offsets | Punboxed_float -> true | Punboxed_int _ -> true | Pvalue Pintval -> true - | Pvalue _ -> false) + | Pvalue _ -> false + | Punboxed_product _ -> Misc.fatal_error "TODO") free_vars in let free_variable_offsets, free_variable_pos = diff --git a/ocaml/middle_end/flambda/flambda_to_clambda.ml b/ocaml/middle_end/flambda/flambda_to_clambda.ml index 591e91da625..c64c0ab5c7e 100644 --- a/ocaml/middle_end/flambda/flambda_to_clambda.ml +++ b/ocaml/middle_end/flambda/flambda_to_clambda.ml @@ -711,7 +711,8 @@ and to_clambda_set_of_closures t env | Punboxed_float -> true | Punboxed_int _ -> true | Pvalue Pintval -> true - | Pvalue _ -> false) + | Pvalue _ -> false + | Punboxed_product _ -> Misc.fatal_error "TBD") free_vars in let to_closure_args free_vars = diff --git a/ocaml/middle_end/internal_variable_names.ml b/ocaml/middle_end/internal_variable_names.ml index 4fb6290a49b..536c9a627ed 100644 --- a/ocaml/middle_end/internal_variable_names.ml +++ b/ocaml/middle_end/internal_variable_names.ml @@ -314,6 +314,10 @@ let punbox_int = "Punbox_int" let pbox_int = "Pbox_int" let punbox_int_arg = "Punbox_int_arg" let pbox_int_arg = "Pbox_int_arg" +let pmake_unboxed_product = "Pmake_unboxed_product" +let punboxed_product_field = "Punboxed_product_field" +let pmake_unboxed_product_arg = "Pmake_unboxed_product_arg" +let punboxed_product_field_arg = "Punboxed_product_field_arg" let anon_fn_with_loc (sloc: Lambda.scoped_location) = let loc = Debuginfo.Scoped_location.to_location sloc in @@ -439,6 +443,8 @@ let of_primitive : Lambda.primitive -> string = function | Pbox_int _ -> pbox_int | Parray_of_iarray -> parray_of_iarray | Parray_to_iarray -> parray_to_iarray + | Pmake_unboxed_product _ -> pmake_unboxed_product + | Punboxed_product_field _ -> punboxed_product_field let of_primitive_arg : Lambda.primitive -> string = function | Pbytes_of_string -> pbytes_of_string_arg @@ -553,3 +559,5 @@ let of_primitive_arg : Lambda.primitive -> string = function | Pbox_int _ -> pbox_int_arg | Parray_of_iarray -> parray_of_iarray_arg | Parray_to_iarray -> parray_to_iarray_arg + | Pmake_unboxed_product _ -> pmake_unboxed_product_arg + | Punboxed_product_field _ -> punboxed_product_field_arg diff --git a/ocaml/middle_end/printclambda.ml b/ocaml/middle_end/printclambda.ml index 46056115b85..f4ae9064a50 100644 --- a/ocaml/middle_end/printclambda.ml +++ b/ocaml/middle_end/printclambda.ml @@ -60,6 +60,7 @@ let layout (layout : Lambda.layout) = | Punboxed_int Pint32 -> ":unboxed_int32" | Punboxed_int Pint64 -> ":unboxed_int64" | Punboxed_int Pnativeint -> ":unboxed_nativeint" + | Punboxed_product _ -> Misc.fatal_error "TODO" let rec structured_constant ppf = function | Uconst_float x -> fprintf ppf "%F" x diff --git a/ocaml/ocamldoc/odoc_sig.ml b/ocaml/ocamldoc/odoc_sig.ml index c087051e252..cf3dc667598 100644 --- a/ocaml/ocamldoc/odoc_sig.ml +++ b/ocaml/ocamldoc/odoc_sig.ml @@ -417,7 +417,7 @@ module Analyser = { Typedtree.ld_id; ld_mutable; ld_type; ld_loc; ld_attributes } = get_field env comments @@ {Types.ld_id; ld_mutable; ld_global = Unrestricted; - ld_layout=Layout.any (* ignored *); + ld_layout=Layout.any ~why:Dummy_layout (* ignored *); ld_type=ld_type.Typedtree.ctyp_type; ld_loc; ld_attributes; ld_uid=Types.Uid.internal_not_actually_unique} in let open Typedtree in diff --git a/ocaml/otherlibs/systhreads/st_stubs.c b/ocaml/otherlibs/systhreads/st_stubs.c index 4003ab62073..3a46363332d 100644 --- a/ocaml/otherlibs/systhreads/st_stubs.c +++ b/ocaml/otherlibs/systhreads/st_stubs.c @@ -880,6 +880,8 @@ CAMLprim value caml_thread_yield(value unit) /* ML */ caml_raise_async_if_exception(caml_process_pending_signals_exn(), "signal handler"); caml_thread_save_runtime_state(); + /* caml_locking_scheme may have changed in caml_process_pending_signals_exn */ + s = atomic_load(&caml_locking_scheme); s->yield(s->context); if (atomic_load(&caml_locking_scheme) != s) { /* The lock we have is no longer the runtime lock */ diff --git a/ocaml/parsing/builtin_attributes.ml b/ocaml/parsing/builtin_attributes.ml index ee8b13eea49..04c48ee64e9 100644 --- a/ocaml/parsing/builtin_attributes.ml +++ b/ocaml/parsing/builtin_attributes.ml @@ -108,12 +108,42 @@ let builtin_attrs = ; "tail_mod_cons"; "ocaml.tail_mod_cons" ] -let builtin_attrs = - let tbl = Hashtbl.create 128 in - List.iter (fun attr -> Hashtbl.add tbl attr ()) builtin_attrs; - tbl +(* nroberts: When we upstream the builtin-attribute whitelisting, we shouldn't + upstream the "jane" prefix. + - Internally, we use "jane.*" to encode our changes to the parsetree, + and our compiler should not drop these attributes. + - Upstream, ppxes may produce attributes with the "jane.*" prefix. + The upstream compiler does not use these attributes. We want it to be + able to drop these attributes without a warning. + + It's an error for an upstream ppx to create an attribute that corresponds to + a *non-erasable* Jane language extension, like list comprehensions, which + should never reach the upstream compiler. So, we distinguish that in the + attribute prefix: upstream ppxlib will error out if it sees a ppx creating a + "jane.non_erasable" attribute and be happy to accept a "jane.erasable" + attribute. Meanwhile, an internal patched version of ppxlib will be happy for + a ppx to produce either of these attributes. +*) +let builtin_attr_prefixes = + [ "jane" + ] -let is_builtin_attr s = Hashtbl.mem builtin_attrs s +let is_builtin_attr = + let builtin_attrs = + let tbl = Hashtbl.create 128 in + List.iter + (fun attr -> Hashtbl.add tbl attr ()) + (builtin_attr_prefixes @ builtin_attrs); + tbl + in + let builtin_attr_prefixes_with_trailing_dot = + List.map (fun x -> x ^ ".") builtin_attr_prefixes + in + fun s -> + Hashtbl.mem builtin_attrs s + || List.exists + (fun prefix -> String.starts_with ~prefix s) + builtin_attr_prefixes_with_trailing_dot type attr_tracking_time = Parser | Invariant_check @@ -424,7 +454,8 @@ let explicit_arity attrs = let layout ~legacy_immediate attrs = let layout = List.find_map - (fun a -> match a.attr_name.txt with + (fun a -> + match a.attr_name.txt with | "ocaml.void"|"void" -> Some (a, Void) | "ocaml.value"|"value" -> Some (a, Value) | "ocaml.any"|"any" -> Some (a, Any) @@ -435,21 +466,22 @@ let layout ~legacy_immediate attrs = in match layout with | None -> Ok None - | Some (a, Value) -> - mark_used a.attr_name; - Ok (Some Value) - | Some (a, (Immediate | Immediate64 as l)) -> - mark_used a.attr_name; - if legacy_immediate - || Language_extension.( is_enabled (Layouts Beta) - || is_enabled (Layouts Alpha)) - then Ok (Some l) - else Error (a.attr_loc, l) - | Some (a, (Any | Void as l)) -> - mark_used a.attr_name; - if Language_extension.is_enabled (Layouts Alpha) - then Ok (Some l) - else Error (a.attr_loc, l) + | Some (a, l) -> + mark_used a.attr_name; + let l_loc = Location.mkloc l a.attr_loc in + let check b = + if b + then Ok (Some l_loc) + else Error l_loc + in + match l with + | Value -> check true + | Immediate | Immediate64 -> + check (legacy_immediate + || Language_extension.( is_enabled (Layouts Beta) + || is_enabled (Layouts Alpha))) + | Any | Void -> + check (Language_extension.is_enabled (Layouts Alpha)) (* The "ocaml.boxed (default)" and "ocaml.unboxed (default)" attributes cannot be input by the user, they are added by the diff --git a/ocaml/parsing/builtin_attributes.mli b/ocaml/parsing/builtin_attributes.mli index ddaa4d1404b..dc7743b9526 100644 --- a/ocaml/parsing/builtin_attributes.mli +++ b/ocaml/parsing/builtin_attributes.mli @@ -199,4 +199,5 @@ val tailcall : Parsetree.attributes -> (* CR layouts: we should eventually be able to delete ~legacy_immediate (after we turn on layouts by default). *) val layout : legacy_immediate:bool -> Parsetree.attributes -> - (Asttypes.const_layout option, Location.t * Asttypes.const_layout) result + (Asttypes.const_layout Location.loc option, + Asttypes.const_layout Location.loc) result diff --git a/ocaml/parsing/jane_syntax.ml b/ocaml/parsing/jane_syntax.ml index ae91667e151..236ab4ce9b8 100644 --- a/ocaml/parsing/jane_syntax.ml +++ b/ocaml/parsing/jane_syntax.ml @@ -12,23 +12,25 @@ open Jane_syntax_parsing that both [comprehensions] and [immutable_arrays] are enabled. But our general mechanism for checking for enabled extensions (in [of_ast]) won't work well here: it triggers when converting from - e.g. [[%jane.comprehensions.array] ...] to the comprehensions-specific - AST. But if we spot a [[%jane.comprehensions.immutable]], there is no - expression to translate. So we just check for the immutable arrays extension - when processing a comprehension expression for an immutable array. + e.g. [[%jane.non_erasable.comprehensions.array] ...] to the + comprehensions-specific AST. But if we spot a + [[%jane.non_erasable.comprehensions.immutable]], there is no expression to + translate. So we just check for the immutable arrays extension when + processing a comprehension expression for an immutable array. Note [Wrapping with make_entire_jane_syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The topmost node in the encoded AST must always look like e.g. - [%jane.comprehensions]. This allows the decoding machinery to know what - extension is being used and what function to call to do the decoding. - Accordingly, during encoding, after doing the hard work of converting the - extension syntax tree into e.g. Parsetree.expression, we need to make a final - step of wrapping the result in an [%jane.xyz] node. Ideally, this step would - be done by part of our general structure, like we separate [of_ast] and - [of_ast_internal] in the decode structure; this design would make it - structurally impossible/hard to forget taking this final step. + [%jane.non_erasable.comprehensions]. (More generally, + [%jane.ERASABILITY.FEATURE] or [@jane.ERASABILITY.FEATURE].) This allows the + decoding machinery to know what extension is being used and what function to + call to do the decoding. Accordingly, during encoding, after doing the hard + work of converting the extension syntax tree into e.g. Parsetree.expression, + we need to make a final step of wrapping the result in a [%jane.*.xyz] node. + Ideally, this step would be done by part of our general structure, like we + separate [of_ast] and [of_ast_internal] in the decode structure; this design + would make it structurally impossible/hard to forget taking this final step. However, the final step is only one line of code (a call to [make_entire_jane_syntax]), but yet the name of the feature varies, as does @@ -43,7 +45,8 @@ module With_attributes = With_attributes (** List and array comprehensions *) module Comprehensions = struct - let extension_string = Language_extension.to_string Comprehensions + let feature : Feature.t = Language_extension Comprehensions + let extension_string = Feature.extension_component feature type iterator = | Range of { start : expression @@ -93,7 +96,7 @@ module Comprehensions = struct let comprehension_expr names x = AST.wrap_desc Expression ~attrs:[] ~loc:x.pexp_loc @@ - AST.make_jane_syntax Expression (extension_string :: names) x + AST.make_jane_syntax Expression feature names x (** First, we define how to go from the nice AST to the OCaml AST; this is the [expr_of_...] family of expressions, culminating in @@ -142,7 +145,7 @@ module Comprehensions = struct let expr_of ~loc cexpr = (* See Note [Wrapping with make_entire_jane_syntax] *) - AST.make_entire_jane_syntax Expression ~loc extension_string (fun () -> + AST.make_entire_jane_syntax Expression ~loc feature (fun () -> match cexpr with | Cexp_list_comprehension comp -> expr_of_comprehension ~type_:["list"] comp @@ -180,7 +183,7 @@ module Comprehensions = struct Location.errorf ~loc "Unknown, unexpected, or malformed@ comprehension embedded term %a" Embedded_name.pp_quoted_name - Embedded_name.(extension_string :: subparts) + (Embedded_name.of_feature feature subparts) | No_clauses -> Location.errorf ~loc "Tried to desugar a comprehension with no clauses" @@ -200,11 +203,14 @@ module Comprehensions = struct attribute removed. *) let expand_comprehension_extension_expr expr = match find_and_remove_jane_syntax_attribute expr.pexp_attributes with - | Some (comprehensions :: names, attributes) - when String.equal comprehensions extension_string -> - names, { expr with pexp_attributes = attributes } - | Some (ext_name, _) -> - Desugaring_error.raise expr (Non_comprehension_embedding ext_name) + | Some (ext_name, attributes) -> begin + match Jane_syntax_parsing.Embedded_name.components ext_name with + | comprehensions :: names + when String.equal comprehensions extension_string -> + names, { expr with pexp_attributes = attributes } + | _ :: _ -> + Desugaring_error.raise expr (Non_comprehension_embedding ext_name) + end | None -> Desugaring_error.raise expr Non_embedding @@ -278,12 +284,12 @@ module Immutable_arrays = struct type nonrec pattern = | Iapat_immutable_array of pattern list - let extension_string = Language_extension.to_string Immutable_arrays + let feature : Feature.t = Language_extension Immutable_arrays let expr_of ~loc = function | Iaexp_immutable_array elts -> (* See Note [Wrapping with make_entire_jane_syntax] *) - AST.make_entire_jane_syntax Expression ~loc extension_string (fun () -> + AST.make_entire_jane_syntax Expression ~loc feature (fun () -> Ast_helper.Exp.array elts) (* Returns remaining unconsumed attributes *) @@ -294,7 +300,7 @@ module Immutable_arrays = struct let pat_of ~loc = function | Iapat_immutable_array elts -> (* See Note [Wrapping with make_entire_jane_syntax] *) - AST.make_entire_jane_syntax Pattern ~loc extension_string (fun () -> + AST.make_entire_jane_syntax Pattern ~loc feature (fun () -> Ast_helper.Pat.array elts) (* Returns remaining unconsumed attributes *) @@ -311,13 +317,13 @@ module Include_functor = struct type structure_item = | Ifstr_include_functor of include_declaration - let extension_string = Language_extension.to_string Include_functor + let feature : Feature.t = Language_extension Include_functor let sig_item_of ~loc = function | Ifsig_include_functor incl -> (* See Note [Wrapping with make_entire_jane_syntax] *) - AST.make_entire_jane_syntax Signature_item ~loc extension_string - (fun () -> Ast_helper.Sig.include_ incl) + AST.make_entire_jane_syntax Signature_item ~loc feature (fun () -> + Ast_helper.Sig.include_ incl) let of_sig_item sigi = match sigi.psig_desc with | Psig_include incl -> Ifsig_include_functor incl @@ -326,8 +332,8 @@ module Include_functor = struct let str_item_of ~loc = function | Ifstr_include_functor incl -> (* See Note [Wrapping with make_entire_jane_syntax] *) - AST.make_entire_jane_syntax Structure_item ~loc extension_string - (fun () -> Ast_helper.Str.include_ incl) + AST.make_entire_jane_syntax Structure_item ~loc feature (fun () -> + Ast_helper.Str.include_ incl) let of_str_item stri = match stri.pstr_desc with | Pstr_include incl -> Ifstr_include_functor incl @@ -339,7 +345,7 @@ module Strengthen = struct type nonrec module_type = { mty : Parsetree.module_type; mod_id : Longident.t Location.loc } - let extension_string = Language_extension.to_string Module_strengthening + let feature : Feature.t = Language_extension Module_strengthening (* Encoding: [S with M] becomes [functor (_ : S) -> (module M)], where the [(module M)] is a [Pmty_alias]. This isn't syntax we can write, but @@ -347,7 +353,7 @@ module Strengthen = struct let mty_of ~loc { mty; mod_id } = (* See Note [Wrapping with make_entire_jane_syntax] *) - AST.make_entire_jane_syntax Module_type ~loc extension_string (fun () -> + AST.make_entire_jane_syntax Module_type ~loc feature (fun () -> Ast_helper.Mty.functor_ (Named (Location.mknoloc None, mty)) (Ast_helper.Mty.alias mod_id)) diff --git a/ocaml/parsing/jane_syntax_parsing.ml b/ocaml/parsing/jane_syntax_parsing.ml index 67a87be6c3e..79ca732278d 100644 --- a/ocaml/parsing/jane_syntax_parsing.ml +++ b/ocaml/parsing/jane_syntax_parsing.ml @@ -7,23 +7,30 @@ of the syntax indicated by the attribute. 2. As a pair of an extension node and an AST item that serves as the "body". Here, the "pair" is embedded as a pair-like construct in the relevant AST - category, e.g. [include sig [%%extension.EXTNAME];; BODY end] for + category, e.g. [include sig [%jane.ERASABILITY.EXTNAME];; BODY end] for signature items. - In particular, for an extension named [EXTNAME] (i.e., one - that is enabled by [-extension EXTNAME] on the command line), the attribute - (if used) must be [[@jane.EXTNAME]], and the extension (if used) must be - [[%jane.EXTNAME]]. For built-in syntax, we use [_builtin] - instead of an extension name. + In particular, for an language extension named [EXTNAME] (i.e., one that is + enabled by [-extension EXTNAME] on the command line), the attribute (if + used) must be [[@jane.ERASABILITY.EXTNAME]], and the extension node (if + used) must be [[%jane.ERASABILITY.EXTNAME]]. For built-in syntax, we use + [_builtin] instead of an language extension name. + + The [ERASABILITY] component indicates to tools such as ocamlformat and + ppxlib whether or not the attribute is erasable. See the documentation of + [Erasability] for more information on how tools make use of this + information. In the below example, we use attributes an examples, but it applies equally to extensions. We also provide utilities for further desugaring similar applications where the embeddings have the longer form - [[@jane.FEATNAME.ID1.ID2.….IDn]] (with the outermost one being the [n = 0] - case), as these might be used inside the [EXPR]. (For example, within the - outermost [[@jane.comprehensions]] term for list and array comprehensions, - we can also use [[@jane.comprehensions.list]], - [[@jane.comprehensions.array]], [[@jane.comprehensions.for.in]], etc.). + [[@jane.ERASABILITY.FEATNAME.ID1.ID2.….IDn]] (with the outermost one being + the [n = 0] case), as these might be used inside the [EXPR]. (For example, + within the outermost [[@jane.non_erasable.comprehensions]] term for list and + array comprehensions, we can also use + [[@jane.non_erasable.comprehensions.list]], + [[@jane.non_erasable.comprehensions.array]], + [[@jane.non_erasable.comprehensions.for.in]], etc.). As mentioned, we represent terms as a "pair" and don't use the extension node or attribute payload; this is so that ppxen can see inside these @@ -42,8 +49,8 @@ We provide one module per syntactic category (e.g., [Expression]), of module type [AST]. They also provide some simple machinery for working with the - general [@jane.FEATNAME.ID1.ID2.….IDn] wrapped forms. To construct one, we - provide [make_jane_syntax]; to destructure one, we provide + general [@jane.ERASABILITY.FEATNAME.ID1.ID2.….IDn] wrapped forms. To + construct one, we provide [make_jane_syntax]; to destructure one, we provide [match_jane_syntax] (which we expose via [make_of_ast]). Users of this module still have to write the transformations in both directions for all new syntax, lowering it to extension nodes or attributes and then lifting it @@ -88,6 +95,8 @@ module Feature : sig val extension_component : t -> string val of_component : string -> (t, error) result + + val is_erasable : t -> bool end = struct type t = Language_extension of Language_extension.t | Builtin @@ -119,11 +128,14 @@ end = struct Error (Disabled_extension ext) | None -> Error (Unknown_extension str) -end -(* FUTURE-PROOFING: We're about to add builtin stuff; delete this ignore-only - binding when we do. *) -let _ = Feature.extension_component + let is_erasable = function + | Language_extension ext -> Language_extension.is_erasable ext + (* Builtin syntax changes don't involve additions or changes to concrete + syntax and are always erasable. + *) + | Builtin -> true +end (** Was this embedded as an [[%extension_node]] or an [[@attribute]]? Not exported. *) @@ -154,14 +166,76 @@ end (******************************************************************************) +module Misnamed_embedding_error = struct + type t = + | No_erasability + | No_feature + | Unknown_erasability of string + + let to_string = function + | No_erasability -> "Missing erasability and feature components" + | No_feature -> "Missing a feature component" + | Unknown_erasability str -> + Printf.sprintf + "Unrecognized component where erasability was expected: `%s'" + str +end + +(** The component of an attribute or extension name that identifies whether or + not the embedded syntax is *erasable*; that is, whether or not the + upstream OCaml compiler can safely interpret the AST while ignoring the + attribute or extension. (This means that syntax encoded as extension + nodes should always be non-erasable.) Tools that consume the parse tree + we generate can make use of this information; for instance, ocamlformat + will use it to guide how we present code that can be run with both our + compiler and the upstream compiler, and ppxlib can use it to decide + whether it's ok to allow ppxes to construct syntax that uses this + emedding. In particular, the upstream version of ppxlib will allow ppxes + to produce [[@jane.erasable.*]] attributes, but will report an error if a + ppx produces a [[@jane.non_erasable.*]] attribute. + + As mentioned above, unlike for attributes, the erasable/non-erasable + distinction is not meaningful for extension nodes, as the compiler will + always error if it sees an uninterpreted extension node. So, for purposes + of tools in the wider OCaml ecosystem, it is irrelevant whether embeddings + that use extension nodes indicate [Erasable] or [Non_erasable] for this + component, but the semantically correct choice and the one we've settled + on is to use [Non_erasable]. *) +module Erasability = struct + type t = + | Erasable + | Non_erasable + + let to_string = function + | Erasable -> "erasable" + | Non_erasable -> "non_erasable" + + let of_string = function + | "erasable" -> Ok Erasable + | "non_erasable" -> Ok Non_erasable + | _ -> Error () +end + (** An AST-style representation of the names used when generating extension nodes or attributes for modular syntax; see the .mli file for more details. *) module Embedded_name : sig - (** A nonempty list of name components, without the leading root component - that identifies it as part of the modular syntax mechanism; see the .mli - file for more details. *) - type t = ( :: ) of string * string list + + (** A nonempty list of name components, without the first two components. + (That is, without the leading root component that identifies it as part of + the modular syntax mechanism, and without the next component that + identifies the erasability.) See the .mli file for more details. *) + type components = ( :: ) of string * string list + + type t = + { erasability : Erasability.t + ; components : components + } + + (** See the mli. *) + val of_feature : Feature.t -> string list -> t + + val components : t -> components (** Convert one of these Jane syntax names to the embedded string form used in the OCaml AST as the name of an extension node or an attribute; not @@ -171,11 +245,12 @@ module Embedded_name : sig (** Parse a Jane syntax name from the OCaml AST, either as the name of an extension node or an attribute: - [Some (Ok _)] if it's a legal Jane-syntax name; - - [Some (Error ())] if it's the bare root name; and + - [Some (Error _)] if the root is present, but the name has fewer than 3 + components or the erasability component is malformed; and - [None] if it doesn't start with the leading root name and isn't part of our Jane-syntax machinery. Not exposed. *) - val of_string : string -> (t, unit) result option + val of_string : string -> (t, Misnamed_embedding_error.t) result option (** Print out the embedded form of a Jane-syntax name, in quotes; for use in error messages. *) @@ -185,11 +260,6 @@ module Embedded_name : sig accompanied by an indefinite article; for use in error messages. Not exposed. *) val pp_a_term : Format.formatter -> Embedding_syntax.t * t -> unit - - (** Print out the illegal empty quasi-Jane-syntax extension node or attribute - with no name beyond the leading root component; for use in error messages. - Not exposed. *) - val pp_bad_empty_term : Format.formatter -> Embedding_syntax.t -> unit end = struct (** The three parameters that control how we encode Jane-syntax extension node names. When updating these, update comments that refer to them by their @@ -207,18 +277,42 @@ end = struct end include Config + let separator_str = String.make 1 separator - type t = ( :: ) of string * string list + type components = ( :: ) of string * string list + + type t = + { erasability : Erasability.t + ; components : components + } + + let of_feature feature trailing_components = + let feature_component = Feature.extension_component feature in + let erasability : Erasability.t = + if Feature.is_erasable feature then Erasable else Non_erasable + in + { erasability; components = feature_component :: trailing_components } - let to_string (feat :: subparts) = - String.concat separator_str (root :: feat :: subparts) + let components t = t.components - let of_string str = match String.split_on_char separator str with + let to_string { erasability; components = feat :: subparts } = + String.concat + separator_str + (root :: Erasability.to_string erasability :: feat :: subparts) + + let of_string str : (t, Misnamed_embedding_error.t) result option = + match String.split_on_char separator str with | root' :: parts when String.equal root root' -> begin match parts with - | feat :: subparts -> Some (Ok (feat :: subparts)) - | [] -> Some (Error ()) + | [] -> Some (Error No_erasability) + | [_] -> Some (Error No_feature) + | erasability :: feat :: subparts -> begin + match Erasability.of_string erasability with + | Ok erasability -> + Some (Ok { erasability; components = feat :: subparts }) + | Error () -> Some (Error (Unknown_erasability erasability)) + end end | _ :: _ | [] -> None @@ -226,13 +320,11 @@ end = struct let pp_a_term ppf (esyn, t) = Format.fprintf ppf "%s %a" article Embedding_syntax.pp (esyn, to_string t) - - let pp_bad_empty_term ppf esyn = Embedding_syntax.pp ppf (esyn, root) end (******************************************************************************) module Error = struct - (** Someone used [[%jane.FEATNAME]]/[[@jane.FEATNAME]] wrong *) + (** Someone used [[%jane.*.FEATNAME]]/[[@jane.*.FEATNAME]] wrong *) type malformed_embedding = | Has_payload of payload @@ -241,10 +333,11 @@ module Error = struct type error = | Malformed_embedding of Embedding_syntax.t * Embedded_name.t * malformed_embedding - | Unknown_extension of Embedding_syntax.t * string + | Unknown_extension of Embedding_syntax.t * Erasability.t * string | Disabled_extension of Language_extension.t | Wrong_syntactic_category of Feature.t * string - | Unnamed_embedding of Embedding_syntax.t + | Misnamed_embedding of + Misnamed_embedding_error.t * string * Embedding_syntax.t | Bad_introduction of Embedding_syntax.t * Embedded_name.t (** The exception type thrown when desugaring a piece of modular syntax from @@ -270,12 +363,13 @@ let report_error ~loc = function (Embedding_syntax.name_plural what) Embedded_name.pp_quoted_name name end - | Unknown_extension (what, name) -> + | Unknown_extension (what, erasability, name) -> + let embedded_name = { Embedded_name.erasability; components = [name] } in Location.errorf ~loc "@[Unknown extension \"%s\" referenced via@ %a %s@]" name - Embedded_name.pp_a_term (what, Embedded_name.[name]) + Embedded_name.pp_a_term (what, embedded_name) (Embedding_syntax.name what) | Disabled_extension ext -> Location.errorf @@ -288,13 +382,14 @@ let report_error ~loc = function "%s cannot appear in %s" (Feature.describe_uppercase feat) cat - | Unnamed_embedding what -> + | Misnamed_embedding (err, name, what) -> Location.errorf ~loc - "Cannot have %s named %a" + "Cannot have %s named %a: %s" (Embedding_syntax.name_indefinite what) - Embedded_name.pp_bad_empty_term what - | Bad_introduction(what, (ext :: _ as name)) -> + Embedding_syntax.pp (what, name) + (Misnamed_embedding_error.to_string err) + | Bad_introduction(what, ({ components = ext :: _; _ } as name)) -> Location.errorf ~loc "@[The extension \"%s\" was referenced improperly; it started with@ \ @@ -302,7 +397,7 @@ let report_error ~loc = function ext Embedded_name.pp_a_term (what, name) (Embedding_syntax.name what) - Embedded_name.pp_a_term (what, Embedded_name.[ext]) + Embedded_name.pp_a_term (what, { name with components = [ext] }) let () = Location.register_error_of_exn @@ -315,9 +410,9 @@ let () = novel syntactic features. One module per variety of AST (expressions, patterns, etc.). *) -(** The parameters that define how to look for [[%jane.FEATNAME]] and - [[@jane.FEATNAME]] inside ASTs of a certain syntactic category. This module - type describes the input to the [Make_with_attribute] and +(** The parameters that define how to look for [[%jane.*.FEATNAME]] and + [[@jane.*.FEATNAME]] inside ASTs of a certain syntactic category. This + module type describes the input to the [Make_with_attribute] and [Make_with_extension_node] functors (though they stipulate additional requirements for their inputs). *) @@ -360,13 +455,6 @@ module type AST = sig val match_jane_syntax : ast -> (Embedded_name.t * ast) option end -(* Some extensions written before this file existed are handled in their own - way; this function filters them out. *) -let uniformly_handled_extension name = - match name with - | "local"|"global"|"nonlocal"|"escape"|"curry" -> false - | _ -> true - (* Parses the embedded name from an embedding, raising if the embedding is malformed. Malformed means either: @@ -378,8 +466,7 @@ let uniformly_handled_extension name = let parse_embedding_exn ~loc ~payload ~name ~embedding_syntax = let raise_error err = raise (Error (loc, err)) in match Embedded_name.of_string name with - | Some (Ok (feat :: _ as name)) - when uniformly_handled_extension feat -> begin + | Some (Ok name) -> begin let raise_malformed err = raise_error (Malformed_embedding (embedding_syntax, name, err)) in @@ -387,8 +474,9 @@ let parse_embedding_exn ~loc ~payload ~name ~embedding_syntax = | PStr [] -> Some name | _ -> raise_malformed (Has_payload payload) end - | Some (Error ()) -> raise_error (Unnamed_embedding embedding_syntax) - | Some (Ok (_ :: _)) | None -> None + | Some (Error err) -> + raise_error (Misnamed_embedding (err, name, embedding_syntax)) + | None -> None module With_attributes = struct type 'desc t = @@ -717,12 +805,20 @@ module AST = struct let (module AST) = to_module t in AST.wrap_desc - let make_jane_syntax (type ast ast_desc) (t : (ast, ast_desc) t) = + let make_jane_syntax + (type ast ast_desc) + (t : (ast, ast_desc) t) + feature + trailing_components + ast + = let (module AST) = to_module t in AST.make_jane_syntax + (Embedded_name.of_feature feature trailing_components) + ast - let make_entire_jane_syntax t ~loc name ast = - make_jane_syntax t [name] + let make_entire_jane_syntax t ~loc feature ast = + make_jane_syntax t feature [] (Ast_helper.with_default_loc (Location.ghostify loc) ast) (** Generically lift our custom ASTs for our novel syntax from OCaml ASTs. *) @@ -732,7 +828,7 @@ module AST = struct let loc = AST.location ast in let raise_error err = raise (Error (loc, err)) in match AST.match_jane_syntax ast with - | Some ([name], ast) -> begin + | Some ({ erasability; components = [name] }, ast) -> begin match Feature.of_component name with | Ok feat -> begin match of_ast_internal feat ast with @@ -743,10 +839,10 @@ module AST = struct | Error err -> raise_error begin match err with | Disabled_extension ext -> Disabled_extension ext | Unknown_extension name -> - Unknown_extension (AST.embedding_syntax, name) + Unknown_extension (AST.embedding_syntax, erasability, name) end end - | Some (_ :: _ :: _ as name, _) -> + | Some ({ components = _ :: _ :: _; _ } as name, _) -> raise_error (Bad_introduction(AST.embedding_syntax, name)) | None -> None in diff --git a/ocaml/parsing/jane_syntax_parsing.mli b/ocaml/parsing/jane_syntax_parsing.mli index 8f939ee0dff..5ca82ff25a5 100644 --- a/ocaml/parsing/jane_syntax_parsing.mli +++ b/ocaml/parsing/jane_syntax_parsing.mli @@ -96,6 +96,11 @@ module Feature : sig type t = | Language_extension of Language_extension.t | Builtin + + (** The component of an attribute or extension name that identifies the + feature. This is third component. + *) + val extension_component : t -> string end (** An AST-style representation of the names used when generating extension @@ -105,11 +110,27 @@ end also why we don't expose any functions for rendering or parsing these names; that's all handled internally. *) module Embedded_name : sig - (** A nonempty list of name components, without the leading root component - that identifies it as part of the modular syntax mechanism. This is a - nonempty list corresponding to the different components of the name: first - the feature, and then any subparts. *) - type t = ( :: ) of string * string list + + (** A nonempty list of name components, without the first two components. + (That is, without the leading root component that identifies it as part of + the modular syntax mechanism, and without the next component that + identifies the erasability.) + + This is a nonempty list corresponding to the different components of the + name: first the feature, and then any subparts. + *) + type components = ( :: ) of string * string list + + type t + + (** Creates an embedded name whose erasability component is whether the + feature is erasable, and whose feature component is the feature's name. + The second argument is treated as the trailing components after the + feature name. + *) + val of_feature : Feature.t -> string list -> t + + val components : t -> components (** Print out the embedded form of a Jane-syntax name, in quotes; for use in error messages. *) @@ -168,8 +189,12 @@ module AST : sig given name (the [Embedded_name.t]) and body (the [ast]). Any locations in the generated AST will be set to [!Ast_helper.default_loc], which should be [ghost]. *) - val make_jane_syntax : - ('ast, 'ast_desc) t -> Embedded_name.t -> 'ast -> 'ast_desc + val make_jane_syntax + : ('ast, 'ast_desc) t + -> Feature.t + -> string list + -> 'ast + -> 'ast_desc (** As [make_jane_syntax], but specifically for the AST node corresponding to the entire piece of novel syntax (e.g., for a list comprehension, the @@ -180,7 +205,7 @@ module AST : sig val make_entire_jane_syntax : ('ast, 'ast_desc) t -> loc:Location.t - -> string + -> Feature.t -> (unit -> 'ast) -> 'ast_desc @@ -239,8 +264,9 @@ val assert_extension_enabled : loc:Location.t -> Language_extension.t -> unit order to process a Jane Syntax element that consists of multiple nested ASTs. *) -val find_and_remove_jane_syntax_attribute : - Parsetree.attributes -> (Embedded_name.t * Parsetree.attributes) option +val find_and_remove_jane_syntax_attribute + : Parsetree.attributes + -> (Embedded_name.t * Parsetree.attributes) option (** Errors around the representation of our extended ASTs. These should mostly just be fatal, but they're needed for one test case diff --git a/ocaml/parsing/location.ml b/ocaml/parsing/location.ml index 2c7046f11ad..5d77c90d4e4 100644 --- a/ocaml/parsing/location.ml +++ b/ocaml/parsing/location.ml @@ -82,6 +82,7 @@ type 'a loc = { let mkloc txt loc = { txt ; loc } let mknoloc txt = mkloc txt none +let get_txt { txt } = txt (******************************************************************************) (* Input info *) diff --git a/ocaml/parsing/location.mli b/ocaml/parsing/location.mli index 4e124614fee..5bda0f5361a 100644 --- a/ocaml/parsing/location.mli +++ b/ocaml/parsing/location.mli @@ -90,7 +90,7 @@ type 'a loc = { val mknoloc : 'a -> 'a loc val mkloc : 'a -> t -> 'a loc - +val get_txt : 'a loc -> 'a (** {1 Input info} *) diff --git a/ocaml/runtime/major_gc.c b/ocaml/runtime/major_gc.c index 5469d0325b7..e9cd9fcdec0 100644 --- a/ocaml/runtime/major_gc.c +++ b/ocaml/runtime/major_gc.c @@ -69,7 +69,12 @@ extern value caml_fl_merge; /* Defined in freelist.c. */ static char *redarken_first_chunk = NULL; static char *sweep_chunk; -static double p_backlog = 0.0; /* backlog for the gc speedup parameter */ + +/* Part of the major slice left for future slices since otherwise a + single slice would be too big. + + In units of words so that it remains consistent across heap size growth */ +static uintnat backlog_words = 0; int caml_gc_subphase; /* Subphase_{mark_roots,mark_main,mark_final} */ @@ -398,6 +403,7 @@ static void start_cycle (void) CAMLassert (redarken_first_chunk == NULL); caml_gc_message (0x01, "Starting new major GC cycle\n"); marked_words = 0; + backlog_words = 0; caml_darken_all_roots_start (); caml_gc_phase = Phase_mark; heap_wsz_at_cycle_start = Caml_state->stat_heap_wsz; @@ -996,10 +1002,10 @@ void caml_major_collection_slice (intnat howmuch) } if (p < dp) p = dp; if (p < caml_extra_heap_resources) p = caml_extra_heap_resources; - p += p_backlog; - p_backlog = 0.0; + p += (double)backlog_words / (double)Caml_state->stat_heap_wsz; + backlog_words = 0; if (p > 0.3){ - p_backlog = p - 0.3; + backlog_words = (uintnat)((p - 0.3) * (double)Caml_state->stat_heap_wsz); p = 0.3; } @@ -1018,8 +1024,8 @@ void caml_major_collection_slice (intnat howmuch) ARCH_INTNAT_PRINTF_FORMAT "du\n", (intnat) (p * 1000000)); caml_gc_message (0x40, "work backlog = %" - ARCH_INTNAT_PRINTF_FORMAT "du\n", - (intnat) (p_backlog * 1000000)); + ARCH_INTNAT_PRINTF_FORMAT "d\n", + backlog_words); for (i = 0; i < caml_major_window; i++){ caml_major_ring[i] += p / caml_major_window; @@ -1164,7 +1170,6 @@ void caml_major_collection_slice (intnat howmuch) void caml_finish_major_cycle (void) { if (caml_gc_phase == Phase_idle){ - p_backlog = 0.0; /* full major GC cycle, the backlog becomes irrelevant */ start_cycle (); } while (caml_gc_phase == Phase_mark) mark_slice (LONG_MAX); diff --git a/ocaml/testsuite/tests/jane-modular-syntax/user_error1.compilers.reference b/ocaml/testsuite/tests/jane-modular-syntax/user_error1.compilers.reference index 2e1ded53db9..30145e46aed 100644 --- a/ocaml/testsuite/tests/jane-modular-syntax/user_error1.compilers.reference +++ b/ocaml/testsuite/tests/jane-modular-syntax/user_error1.compilers.reference @@ -1,5 +1,5 @@ -File "user_error1.ml", line 21, characters 44-58: -21 | let _malformed_extension_has_payload = () [@jane.something "no payloads"];; - ^^^^^^^^^^^^^^ +File "user_error1.ml", line 21, characters 44-67: +21 | let _malformed_extension_has_payload = () [@jane.erasable.something "no payloads"];; + ^^^^^^^^^^^^^^^^^^^^^^^ Error: Modular syntax attributes are not allowed to have a payload, - but "jane.something" does + but "jane.erasable.something" does diff --git a/ocaml/testsuite/tests/jane-modular-syntax/user_error1.ml b/ocaml/testsuite/tests/jane-modular-syntax/user_error1.ml index 42a47335f62..27c5c550d66 100644 --- a/ocaml/testsuite/tests/jane-modular-syntax/user_error1.ml +++ b/ocaml/testsuite/tests/jane-modular-syntax/user_error1.ml @@ -18,5 +18,5 @@ like it in separate files, because the "compile and test output" infrastructure reports only one error at a time. *) -let _malformed_extension_has_payload = () [@jane.something "no payloads"];; +let _malformed_extension_has_payload = () [@jane.erasable.something "no payloads"];; diff --git a/ocaml/testsuite/tests/jane-modular-syntax/user_error2.compilers.reference b/ocaml/testsuite/tests/jane-modular-syntax/user_error2.compilers.reference index 179d53c15e3..a94b0d0b93d 100644 --- a/ocaml/testsuite/tests/jane-modular-syntax/user_error2.compilers.reference +++ b/ocaml/testsuite/tests/jane-modular-syntax/user_error2.compilers.reference @@ -1,4 +1,4 @@ -File "user_error2.ml", line 21, characters 46-60: -21 | let _malformed_extensions_wrong_arguments = [%jane.something] "two" "arguments";; - ^^^^^^^^^^^^^^ -Error: Uninterpreted extension 'jane.something'. +File "user_error2.ml", line 21, characters 46-69: +21 | let _malformed_extensions_wrong_arguments = [%jane.erasable.something] "two" "arguments";; + ^^^^^^^^^^^^^^^^^^^^^^^ +Error: Uninterpreted extension 'jane.erasable.something'. diff --git a/ocaml/testsuite/tests/jane-modular-syntax/user_error2.ml b/ocaml/testsuite/tests/jane-modular-syntax/user_error2.ml index c09ca9743e1..805f5cd4ded 100644 --- a/ocaml/testsuite/tests/jane-modular-syntax/user_error2.ml +++ b/ocaml/testsuite/tests/jane-modular-syntax/user_error2.ml @@ -18,4 +18,4 @@ like it in separate files, because the "compile and test output" infrastructure reports only one error at a time. *) -let _malformed_extensions_wrong_arguments = [%jane.something] "two" "arguments";; +let _malformed_extensions_wrong_arguments = [%jane.erasable.something] "two" "arguments";; diff --git a/ocaml/testsuite/tests/jane-modular-syntax/user_error3.compilers.reference b/ocaml/testsuite/tests/jane-modular-syntax/user_error3.compilers.reference index 6a01f3565b2..51ad08bf367 100644 --- a/ocaml/testsuite/tests/jane-modular-syntax/user_error3.compilers.reference +++ b/ocaml/testsuite/tests/jane-modular-syntax/user_error3.compilers.reference @@ -1,5 +1,5 @@ -File "user_error3.ml", line 21, characters 25-27: -21 | let _unknown_extension = () [@jane.this_extension_doesn't_exist];; - ^^ +File "user_error3.ml", line 21, characters 26-28: +21 | let _misnamed_extension = () [@jane.erasable.this_extension_doesn't_exist];; + ^^ Error: Unknown extension "this_extension_doesn't_exist" referenced via - a [@jane.this_extension_doesn't_exist] attribute + a [@jane.erasable.this_extension_doesn't_exist] attribute diff --git a/ocaml/testsuite/tests/jane-modular-syntax/user_error3.ml b/ocaml/testsuite/tests/jane-modular-syntax/user_error3.ml index fc2584f2be3..a18058ccb60 100644 --- a/ocaml/testsuite/tests/jane-modular-syntax/user_error3.ml +++ b/ocaml/testsuite/tests/jane-modular-syntax/user_error3.ml @@ -18,4 +18,4 @@ like it in separate files, because the "compile and test output" infrastructure reports only one error at a time. *) -let _unknown_extension = () [@jane.this_extension_doesn't_exist];; +let _misnamed_extension = () [@jane.erasable.this_extension_doesn't_exist];; diff --git a/ocaml/testsuite/tests/jane-modular-syntax/user_error3_1.compilers.reference b/ocaml/testsuite/tests/jane-modular-syntax/user_error3_1.compilers.reference new file mode 100644 index 00000000000..1af2e3db578 --- /dev/null +++ b/ocaml/testsuite/tests/jane-modular-syntax/user_error3_1.compilers.reference @@ -0,0 +1,4 @@ +File "user_error3_1.ml", line 9, characters 31-55: +9 | let _misnamed_extension = () [@jane.invalid_erasability];; + ^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Cannot have an attribute named [@jane.invalid_erasability]: Missing a feature component diff --git a/ocaml/testsuite/tests/jane-modular-syntax/user_error3_1.ml b/ocaml/testsuite/tests/jane-modular-syntax/user_error3_1.ml new file mode 100644 index 00000000000..4131439b873 --- /dev/null +++ b/ocaml/testsuite/tests/jane-modular-syntax/user_error3_1.ml @@ -0,0 +1,9 @@ +(* TEST + ocamlc_byte_exit_status = "2" + * setup-ocamlc.byte-build-env + ** ocamlc.byte + *** check-ocamlc.byte-output +*) + +(* See the comment in user_error3.ml *) +let _misnamed_extension = () [@jane.invalid_erasability];; diff --git a/ocaml/testsuite/tests/jane-modular-syntax/user_error3_2.compilers.reference b/ocaml/testsuite/tests/jane-modular-syntax/user_error3_2.compilers.reference new file mode 100644 index 00000000000..a7f73ce3c2a --- /dev/null +++ b/ocaml/testsuite/tests/jane-modular-syntax/user_error3_2.compilers.reference @@ -0,0 +1,4 @@ +File "user_error3_2.ml", line 9, characters 31-48: +9 | let _misnamed_extension = () [@jane.non_erasable];; + ^^^^^^^^^^^^^^^^^ +Error: Cannot have an attribute named [@jane.non_erasable]: Missing a feature component diff --git a/ocaml/testsuite/tests/jane-modular-syntax/user_error3_2.ml b/ocaml/testsuite/tests/jane-modular-syntax/user_error3_2.ml new file mode 100644 index 00000000000..9fdf36a3130 --- /dev/null +++ b/ocaml/testsuite/tests/jane-modular-syntax/user_error3_2.ml @@ -0,0 +1,9 @@ +(* TEST + ocamlc_byte_exit_status = "2" + * setup-ocamlc.byte-build-env + ** ocamlc.byte + *** check-ocamlc.byte-output +*) + +(* See the comment in user_error3.ml *) +let _misnamed_extension = () [@jane.non_erasable];; diff --git a/ocaml/testsuite/tests/jane-modular-syntax/user_error3_3.compilers.reference b/ocaml/testsuite/tests/jane-modular-syntax/user_error3_3.compilers.reference new file mode 100644 index 00000000000..ebb6d8a2768 --- /dev/null +++ b/ocaml/testsuite/tests/jane-modular-syntax/user_error3_3.compilers.reference @@ -0,0 +1,4 @@ +File "user_error3_3.ml", line 9, characters 31-63: +9 | let _misnamed_extension = () [@jane.invalid_erasability.feature];; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Cannot have an attribute named [@jane.invalid_erasability.feature]: Unrecognized component where erasability was expected: `invalid_erasability' diff --git a/ocaml/testsuite/tests/jane-modular-syntax/user_error3_3.ml b/ocaml/testsuite/tests/jane-modular-syntax/user_error3_3.ml new file mode 100644 index 00000000000..ffc73b28cc7 --- /dev/null +++ b/ocaml/testsuite/tests/jane-modular-syntax/user_error3_3.ml @@ -0,0 +1,9 @@ +(* TEST + ocamlc_byte_exit_status = "2" + * setup-ocamlc.byte-build-env + ** ocamlc.byte + *** check-ocamlc.byte-output +*) + +(* See the comment in user_error3.ml *) +let _misnamed_extension = () [@jane.invalid_erasability.feature];; diff --git a/ocaml/testsuite/tests/jane-modular-syntax/user_error4.compilers.reference b/ocaml/testsuite/tests/jane-modular-syntax/user_error4.compilers.reference index 5c872b45ae6..43e9aa05b7f 100644 --- a/ocaml/testsuite/tests/jane-modular-syntax/user_error4.compilers.reference +++ b/ocaml/testsuite/tests/jane-modular-syntax/user_error4.compilers.reference @@ -1,4 +1,4 @@ File "user_error4.ml", line 21, characters 26-28: -21 | let _disabled_extension = () [@jane.comprehensions];; +21 | let _disabled_extension = () [@jane.non_erasable.comprehensions];; ^^ Error: The extension "comprehensions" is disabled and cannot be used diff --git a/ocaml/testsuite/tests/jane-modular-syntax/user_error4.ml b/ocaml/testsuite/tests/jane-modular-syntax/user_error4.ml index 35c6fc15bb3..e5575810e9b 100644 --- a/ocaml/testsuite/tests/jane-modular-syntax/user_error4.ml +++ b/ocaml/testsuite/tests/jane-modular-syntax/user_error4.ml @@ -18,4 +18,4 @@ like it in separate files, because the "compile and test output" infrastructure reports only one error at a time. *) -let _disabled_extension = () [@jane.comprehensions];; +let _disabled_extension = () [@jane.non_erasable.comprehensions];; diff --git a/ocaml/testsuite/tests/jane-modular-syntax/user_error5.compilers.reference b/ocaml/testsuite/tests/jane-modular-syntax/user_error5.compilers.reference index 3e2ea8644f0..e0d14e05f18 100644 --- a/ocaml/testsuite/tests/jane-modular-syntax/user_error5.compilers.reference +++ b/ocaml/testsuite/tests/jane-modular-syntax/user_error5.compilers.reference @@ -1,4 +1,4 @@ File "user_error5.ml", line 21, characters 30-34: 21 | let _unnamed_extension = () [@jane];; ^^^^ -Error: Cannot have an attribute named [@jane] +Error: Cannot have an attribute named [@jane]: Missing erasability and feature components diff --git a/ocaml/testsuite/tests/jane-modular-syntax/user_error6.compilers.reference b/ocaml/testsuite/tests/jane-modular-syntax/user_error6.compilers.reference index 2a37167d778..bc303263d3d 100644 --- a/ocaml/testsuite/tests/jane-modular-syntax/user_error6.compilers.reference +++ b/ocaml/testsuite/tests/jane-modular-syntax/user_error6.compilers.reference @@ -1,5 +1,6 @@ File "user_error6.ml", line 21, characters 24-26: -21 | let _bad_introduction = () [@jane.something.nested];; +21 | let _bad_introduction = () [@jane.erasable.something.nested];; ^^ Error: The extension "something" was referenced improperly; it started with - a [@jane.something.nested] attribute, not a [@jane.something] one + a [@jane.erasable.something.nested] attribute, + not a [@jane.erasable.something] one diff --git a/ocaml/testsuite/tests/jane-modular-syntax/user_error6.ml b/ocaml/testsuite/tests/jane-modular-syntax/user_error6.ml index 55ed4f58481..b126a93dd5e 100644 --- a/ocaml/testsuite/tests/jane-modular-syntax/user_error6.ml +++ b/ocaml/testsuite/tests/jane-modular-syntax/user_error6.ml @@ -18,4 +18,4 @@ like it in separate files, because the "compile and test output" infrastructure reports only one error at a time. *) -let _bad_introduction = () [@jane.something.nested];; +let _bad_introduction = () [@jane.erasable.something.nested];; diff --git a/ocaml/testsuite/tests/jane-modular-syntax/user_error7_attributes.compilers.reference b/ocaml/testsuite/tests/jane-modular-syntax/user_error7_attributes.compilers.reference new file mode 100644 index 00000000000..5e6e63df09e --- /dev/null +++ b/ocaml/testsuite/tests/jane-modular-syntax/user_error7_attributes.compilers.reference @@ -0,0 +1,4 @@ +File "user_error7_attributes.ml", line 21, characters 5-9: +21 | let[@jane] f () = ();; + ^^^^ +Warning 53 [misplaced-attribute]: the "jane" attribute cannot appear in this context diff --git a/ocaml/testsuite/tests/jane-modular-syntax/user_error7_attributes.ml b/ocaml/testsuite/tests/jane-modular-syntax/user_error7_attributes.ml new file mode 100644 index 00000000000..1f3c13e811e --- /dev/null +++ b/ocaml/testsuite/tests/jane-modular-syntax/user_error7_attributes.ml @@ -0,0 +1,25 @@ +(* TEST + + flags = "-w +A-60-70" + + * setup-ocamlc.byte-build-env + ** ocamlc.byte + compile_only = "true" + *** check-ocamlc.byte-output + +*) + +(* + If we use attributes on a syntactic category not handled by modular syntax, + they aren't interpreted by the modular syntax machinery and fail with a normal + OCaml error. + + We may some day run out of such syntactic categories, in which case we should + delete this test and leave a comment saying that we can't write such a test for + attributes because the modular syntax machinery always interprets them. +*) +let[@jane] f () = ();; + +(* We can't use expect test here because warning 53 is only raised by ocamlc, + not the toplevel. This is probably a bug. +*) diff --git a/ocaml/testsuite/tests/jane-modular-syntax/user_error7.ml b/ocaml/testsuite/tests/jane-modular-syntax/user_error7_extensions.ml similarity index 100% rename from ocaml/testsuite/tests/jane-modular-syntax/user_error7.ml rename to ocaml/testsuite/tests/jane-modular-syntax/user_error7_extensions.ml diff --git a/ocaml/testsuite/tests/lib-systhreads/swapgil_stubs.c b/ocaml/testsuite/tests/lib-systhreads/swapgil_stubs.c index 44caae53b39..558a8472155 100644 --- a/ocaml/testsuite/tests/lib-systhreads/swapgil_stubs.c +++ b/ocaml/testsuite/tests/lib-systhreads/swapgil_stubs.c @@ -16,6 +16,7 @@ value blocking_section(value unused) { caml_enter_blocking_section(); caml_leave_blocking_section(); + return Val_unit; } @@ -115,6 +116,7 @@ value swap_gil_setup(value unused) caml_default_locking_scheme.thread_start = runtime_thread_start; caml_default_locking_scheme.thread_stop = runtime_thread_stop; started = 1; + return Val_unit; } value swap_gil(value unused) diff --git a/ocaml/testsuite/tests/typing-layouts-missing-cmi/c.ml b/ocaml/testsuite/tests/typing-layouts-missing-cmi/c.ml index e3bb3234dec..789af7cba7d 100644 --- a/ocaml/testsuite/tests/typing-layouts-missing-cmi/c.ml +++ b/ocaml/testsuite/tests/typing-layouts-missing-cmi/c.ml @@ -45,7 +45,10 @@ Line 1, characters 12-19: ^^^^^^^ Error: This type B.b_value = A.a_value should be an instance of type ('a : immediate) - B.b_value has layout value, which is not a sublayout of immediate. + B.b_value has an unknown layout, + which might not be a sublayout of immediate. + No .cmi file found containing A.a_value. + Hint: Adding "a" to your dependencies might help. |}];; (* type err2 = b_void value_arg;; diff --git a/ocaml/testsuite/tests/typing-layouts/basics.ml b/ocaml/testsuite/tests/typing-layouts/basics.ml index c0fb8840f30..6ff4946e0be 100644 --- a/ocaml/testsuite/tests/typing-layouts/basics.ml +++ b/ocaml/testsuite/tests/typing-layouts/basics.ml @@ -287,3 +287,21 @@ Error: Layout void is used here, but the appropriate layouts extension is not en (* CR layouts: This test moved to [basics_alpha.ml] as it needs a non-value sort. Bring back here when we have one enabled by default. *) + +(*******************************************) +(* Test 29: [external]s default to [value] *) + +(* CR layouts: This test moved to [basics_alpha.ml] as it needs a non-value + sort. Bring back here when we have one enabled by default. *) + +(**************************************) +(* Test 30: [val]s default to [value] *) + +(* CR layouts: This test moved to [basics_alpha.ml] as it needs a non-value + sort. Bring back here when we have one enabled by default. *) + +(**************************************************) +(* Test 31: checking that #poly_var patterns work *) + +(* CR layouts: This test moves to [basics_alpha.ml] as it needs a non-value + sort. Bring back here when we have one enabled by default. *) diff --git a/ocaml/testsuite/tests/typing-layouts/basics_alpha.ml b/ocaml/testsuite/tests/typing-layouts/basics_alpha.ml index a29befa06b4..ad6be5976ed 100644 --- a/ocaml/testsuite/tests/typing-layouts/basics_alpha.ml +++ b/ocaml/testsuite/tests/typing-layouts/basics_alpha.ml @@ -1395,3 +1395,70 @@ Error: This pattern matches values of type t_void but a pattern was expected which matches values of type ('a : value) t_void has layout void, which is not a sublayout of value. |}] + +(*******************************************) +(* Test 29: [external]s default to [value] *) + +(* CR layouts: this must be done in a module so that we can test the + type-checker, as opposed to the value-kind check. After we have proper + support for a non-value argument type, remove the module wrapper. +*) +module _ = struct + external eq : 'a -> 'a -> bool = "%equal" + let mk_void () : t_void = assert false + let x () = eq (mk_void ()) (mk_void ()) +end + +[%%expect{| +Line 4, characters 16-28: +4 | let x () = eq (mk_void ()) (mk_void ()) + ^^^^^^^^^^^^ +Error: This expression has type t_void but an expression was expected of type + ('a : value) + t_void has layout void, which is not a sublayout of value. +|}] + +(**************************************) +(* Test 30: [val]s default to [value] *) + +(* CR layouts: this must be done in a module so that we can test the + type-checker, as opposed to the value-kind check. After we have proper + support for a non-value argument type, remove the module wrapper. +*) +module _ = struct + module M : sig + val f : 'a -> 'a + end = struct + let f x = x + end + + let g (x : t_void) = M.f x +end + +[%%expect{| +Line 8, characters 27-28: +8 | let g (x : t_void) = M.f x + ^ +Error: This expression has type t_void but an expression was expected of type + ('a : value) + t_void has layout void, which is not a sublayout of value. +|}] + +(**************************************************) +(* Test 31: checking that #poly_var patterns work *) + +type ('a : void) poly_var = [`A of int * 'a | `B] + +let f #poly_var = "hello" + +[%%expect{| +Line 1, characters 41-43: +1 | type ('a : void) poly_var = [`A of int * 'a | `B] + ^^ +Error: This type ('a : value) should be an instance of type ('a0 : void) + 'a has layout void, which does not overlap with value. +|}] +(* CR layouts bug: this should be accepted (or maybe we should reject + the type definition if we're not allowing `void` things in structures). + This bug is a goof at the top of Typecore.build_or_pat; + there is another CR layouts there. *) diff --git a/ocaml/testsuite/tests/typing-layouts/basics_beta.ml b/ocaml/testsuite/tests/typing-layouts/basics_beta.ml index db78b4a5795..7dc750ef70d 100644 --- a/ocaml/testsuite/tests/typing-layouts/basics_beta.ml +++ b/ocaml/testsuite/tests/typing-layouts/basics_beta.ml @@ -448,7 +448,7 @@ val f18 : 'a -> 'a = (* Test 22: approx_type catch-all can't be restricted to value *) (* CR layouts: This test moved to [basics_alpha.ml] as it needs a non-value - sort. Bring back here when we have one enabled by default. *) + sort. Bring back here when we have one. *) type t_void [@@void];; [%%expect{| @@ -493,3 +493,21 @@ Error: Layout void is used here, but the appropriate layouts extension is not en (* CR layouts v2: This test moved to [basics_alpha.ml] as it needs a non-value sort. Bring back here when we have one. *) + +(*******************************************) +(* Test 29: [external]s default to [value] *) + +(* CR layouts v2: This test moved to [basics_alpha.ml] as it needs a non-value + sort. Bring back here when we have one. *) + +(**************************************) +(* Test 30: [val]s default to [value] *) + +(* CR layouts v2: This test moved to [basics_alpha.ml] as it needs a non-value + sort. Bring back here when we have one. *) + +(**************************************************) +(* Test 31: checking that #poly_var patterns work *) + +(* CR layouts: This test moves to [basics_alpha.ml] as it needs a non-value + sort. Bring back here when we have one. *) diff --git a/ocaml/testsuite/tests/typing-missing-cmi-2/test.compilers.reference b/ocaml/testsuite/tests/typing-missing-cmi-2/test.compilers.reference index 7e96792bef5..f1ee85e77eb 100644 --- a/ocaml/testsuite/tests/typing-missing-cmi-2/test.compilers.reference +++ b/ocaml/testsuite/tests/typing-missing-cmi-2/test.compilers.reference @@ -3,6 +3,6 @@ File "baz.ml", line 1, characters 8-18: ^^^^^^^^^^ Error: This expression has type 'a Foo.t but an expression was expected of type ('b : '_representable_layout_1) - 'a Foo.t has layout any, which is not representable. + 'a Foo.t has an unknown layout, which might not be representable. No .cmi file found containing Foo.t. Hint: Adding "foo" to your dependencies might help. diff --git a/ocaml/testsuite/tests/typing-missing-cmi-indirections/test.compilers.reference b/ocaml/testsuite/tests/typing-missing-cmi-indirections/test.compilers.reference index ddfa00dab6e..a8cd534433e 100644 --- a/ocaml/testsuite/tests/typing-missing-cmi-indirections/test.compilers.reference +++ b/ocaml/testsuite/tests/typing-missing-cmi-indirections/test.compilers.reference @@ -2,6 +2,6 @@ File "client.ml", line 2, characters 0-19: 2 | and alias = missing ^^^^^^^^^^^^^^^^^^^ Error: - alias has layout any, which is not a sublayout of value. + alias has an unknown layout, which might not be a sublayout of value. No .cmi file found containing Missing.t. Hint: Adding "missing" to your dependencies might help. diff --git a/ocaml/testsuite/tests/typing-missing-cmi/test.compilers.reference b/ocaml/testsuite/tests/typing-missing-cmi/test.compilers.reference index 493ac921989..b75953604d6 100644 --- a/ocaml/testsuite/tests/typing-missing-cmi/test.compilers.reference +++ b/ocaml/testsuite/tests/typing-missing-cmi/test.compilers.reference @@ -2,7 +2,7 @@ File "main.ml", line 1, characters 8-11: 1 | let _ = A.a = B.b ^^^ Error: This expression has type M.a but an expression was expected of type - ('a : '_representable_layout_1) - M.a has layout any, which is not representable. + ('a : value) + M.a has an unknown layout, which might not be a sublayout of value. No .cmi file found containing M.a. Hint: Adding "m" to your dependencies might help. diff --git a/ocaml/toplevel/genprintval.ml b/ocaml/toplevel/genprintval.ml index 7962bb535ff..78b152d866f 100644 --- a/ocaml/toplevel/genprintval.ml +++ b/ocaml/toplevel/genprintval.ml @@ -427,7 +427,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct List.mapi (fun i ty_arg -> (ty_arg, - Layout.(equal void cstr_arg_layouts.(i))) + Layout.is_void_defaulting cstr_arg_layouts.(i)) ) ty_args in tree_of_constr_with_args (tree_of_constr env path) @@ -511,7 +511,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct let name = Ident.name ld_id in (* PR#5722: print full module path only for first record field *) - let is_void = Layout.(equal void ld_layout) in + let is_void = Layout.is_void_defaulting ld_layout in let lid = if first then tree_of_label env path (Out_name.create name) else Oide_ident (Out_name.create name) @@ -616,7 +616,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct in let args = instantiate_types env type_params ty_list cstr.cstr_args in let args = List.mapi (fun i arg -> - (arg, Layout.(equal void cstr.cstr_arg_layouts.(i)))) + (arg, Layout.is_void_defaulting cstr.cstr_arg_layouts.(i))) args in tree_of_constr_with_args diff --git a/ocaml/toplevel/topdirs.ml b/ocaml/toplevel/topdirs.ml index 6646b245edf..dce7c05fb9c 100644 --- a/ocaml/toplevel/topdirs.ml +++ b/ocaml/toplevel/topdirs.ml @@ -233,7 +233,7 @@ let printer_type ppf typename = let match_simple_printer_type desc printer_type = Ctype.begin_def(); - let ty_arg = Ctype.newvar Layout.value in + let ty_arg = Ctype.newvar (Layout.value ~why:Debug_printer_argument) in begin try Ctype.unify !toplevel_env (Ctype.newconstr printer_type [ty_arg]) @@ -247,7 +247,10 @@ let match_simple_printer_type desc printer_type = let match_generic_printer_type desc path args printer_type = Ctype.begin_def(); - let args = List.map (fun _ -> Ctype.newvar Layout.value) args in + let args = List.map + (fun _ -> Ctype.newvar + (Layout.value ~why:Debug_printer_argument)) + args in let ty_target = Ctype.newty (Tconstr (path, args, ref Mnil)) in let ty_args = List.map (fun ty_var -> Ctype.newconstr printer_type [ty_var]) args in diff --git a/ocaml/typing/ctype.ml b/ocaml/typing/ctype.ml index bedb5d7abb8..87459be012b 100644 --- a/ocaml/typing/ctype.ml +++ b/ocaml/typing/ctype.ml @@ -1148,9 +1148,10 @@ let rec copy ?partial ?keep_names scope ty = if forget <> generic_level then (* Using layout "any" is ok here: We're forgetting the type because it will be unified with the original later. *) - newty2 ~level:forget (Tvar { name = None; layout = Layout.any }) + newty2 ~level:forget + (Tvar { name = None; layout = Layout.any ~why:Dummy_layout }) else - let t = newstub ~scope:(get_scope ty) Layout.any in + let t = newstub ~scope:(get_scope ty) (Layout.any ~why:Dummy_layout) in For_copy.redirect_desc scope ty (Tsubst (t, None)); let desc' = match desc with @@ -1215,7 +1216,7 @@ let rec copy ?partial ?keep_names scope ty = if not (eq_type more more') then more' (* we've already made a copy *) else - newvar Layout.value + newvar (Layout.value ~why:Row_variable) in let not_reither (_, f) = match row_field_repr f with @@ -1319,7 +1320,7 @@ let instance_constructor ?in_pattern cstr = let layout = match get_desc existential with | Tvar { layout } -> layout - | Tvariant _ -> Layout.value (* Existential row variable *) + | Tvariant _ -> Layout.value ~why:Row_variable (* Existential row variable *) | _ -> assert false in let decl = new_local_type layout in @@ -1440,7 +1441,7 @@ let rec copy_sep ~cleanup_scope ~fixed ~free ~bound ~may_share if is_Tvar ty || may_share && TypeSet.is_empty univars then if get_level ty <> generic_level then ty else (* layout not consulted during copy_sep, so Any is safe *) - let t = newstub ~scope:(get_scope ty) Layout.any in + let t = newstub ~scope:(get_scope ty) (Layout.any ~why:Dummy_layout) in delayed_copy := lazy (Transient_expr.set_stub_desc t (Tlink (copy cleanup_scope ty))) :: !delayed_copy; @@ -1451,7 +1452,7 @@ let rec copy_sep ~cleanup_scope ~fixed ~free ~bound ~may_share if dl <> [] && conflicts univars dl then raise Not_found; t with Not_found -> begin - let t = newstub ~scope:(get_scope ty) Layout.any in + let t = newstub ~scope:(get_scope ty) (Layout.any ~why:Dummy_layout) in let desc = get_desc ty in let visited = match desc with @@ -1576,7 +1577,7 @@ let subst env level priv abbrev oty params args body = if List.length params <> List.length args then raise Cannot_subst; let old_level = !current_level in current_level := level; - let body0 = newvar Layout.any in (* Stub *) + let body0 = newvar (Layout.any ~why:Dummy_layout) in (* Stub *) let undo_abbrev = match oty with | None -> fun () -> () (* No abbreviation added *) @@ -1942,22 +1943,22 @@ let rec estimate_type_layout env ty = try Layout (Env.find_type p env).type_layout with - Not_found -> Layout (missing_cmi_any p) + Not_found -> Layout (any ~why:(Missing_cmi p)) end | Tvariant row -> if tvariant_not_immediate row - then Layout value - else Layout immediate + then Layout (value ~why:Polymorphic_variant) + else Layout (immediate ~why:Immediate_polymorphic_variant) | Tvar { layout } -> TyVar (layout, ty) - | Tarrow _ -> Layout value - | Ttuple _ -> Layout value - | Tobject _ -> Layout value - | Tfield _ -> Layout value - | Tnil -> Layout value + | Tarrow _ -> Layout (value ~why:Arrow) + | Ttuple _ -> Layout (value ~why:Tuple) + | Tobject _ -> Layout (value ~why:Object) + | Tfield _ -> Layout (value ~why:Tfield) + | Tnil -> Layout (value ~why:Tnil) | (Tlink _ | Tsubst _) -> assert false | Tunivar { layout } -> Layout layout | Tpoly (ty, _) -> estimate_type_layout env ty - | Tpackage _ -> Layout value + | Tpackage _ -> Layout (value ~why:First_class_module) (* The ~fixed argument controls what effects this may have on `ty`. If false, @@ -1977,15 +1978,22 @@ let rec estimate_type_layout env ty = loop trying to also expand [s], and then performing layout checking to ensure it's a valid argument to [t]. (We believe there are still loops like this that can occur, though, and may need a more principled solution later). + + Precondition: [layout] is not [any]. This common case is short-circuited + before calling this function. (Though the current implementation is still + correct on [any].) *) -let rec constrain_type_layout ~reason ~fixed env ty layout fuel = +let rec constrain_type_layout ~fixed env ty layout fuel = let constrain_unboxed ty = match estimate_type_layout env ty with | Layout ty_layout -> Layout.sub ty_layout layout | TyVar (ty_layout, ty) -> if fixed then Layout.sub ty_layout layout else - let layout_inter = Layout.intersection ~reason ty_layout layout in + let layout_inter = + Layout.intersection ~reason:Tyvar_refinement_intersection + ty_layout layout + in Result.map (set_var_layout ty) layout_inter in (* This is an optimization to avoid unboxing if we can tell the constraint is @@ -1994,7 +2002,7 @@ let rec constrain_type_layout ~reason ~fixed env ty layout fuel = | Tconstr(p, _args, _abbrev) -> begin let layout_bound = try (Env.find_type p env).type_layout - with Not_found -> Layout.missing_cmi_any p + with Not_found -> Layout.any ~why:(Missing_cmi p) in match Layout.sub layout_bound layout with | Ok () as ok -> ok @@ -2003,37 +2011,36 @@ let rec constrain_type_layout ~reason ~fixed env ty layout fuel = begin match unbox_once env ty with | Not_unboxed ty -> constrain_unboxed ty | Unboxed ty -> - constrain_type_layout ~reason ~fixed env ty layout (fuel - 1) + constrain_type_layout ~fixed env ty layout (fuel - 1) | Missing missing_cmi_for -> - Error (Layout.Violation.add_missing_cmi_for_lhs - ~missing_cmi_for - violation) + Error (Layout.Violation.record_missing_cmi ~missing_cmi_for violation) end end - | Tpoly (ty, _) -> constrain_type_layout ~reason ~fixed env ty layout fuel + | Tpoly (ty, _) -> constrain_type_layout ~fixed env ty layout fuel | _ -> constrain_unboxed ty -let constrain_type_layout ~reason ~fixed env ty layout fuel = - (* An optimization to avoid doing any work if we're checking against any. *) - if Layout.(equal layout any) then Ok () - else constrain_type_layout ~reason ~fixed env ty layout fuel +let constrain_type_layout ~fixed env ty layout fuel = + (* An optimization to avoid doing any work if we're checking against + any. *) + if Layout.is_any layout then Ok () + else constrain_type_layout ~fixed env ty layout fuel -let check_type_layout ~reason env ty layout = - constrain_type_layout ~reason ~fixed:true env ty layout 100 +let check_type_layout env ty layout = + constrain_type_layout ~fixed:true env ty layout 100 -let constrain_type_layout ~reason env ty layout = - constrain_type_layout ~reason ~fixed:false env ty layout 100 +let constrain_type_layout env ty layout = + constrain_type_layout ~fixed:false env ty layout 100 -let check_decl_layout ~reason env decl layout = +let check_decl_layout env decl layout = match Layout.sub decl.type_layout layout with | Ok () as ok -> ok | Error _ as err -> match decl.type_manifest with | None -> err - | Some ty -> check_type_layout ~reason env ty layout + | Some ty -> check_type_layout env ty layout -let constrain_type_layout_exn ~reason env texn ty layout = - match constrain_type_layout ~reason env ty layout with +let constrain_type_layout_exn env texn ty layout = + match constrain_type_layout env ty layout with | Ok _ -> () | Error err -> raise_for texn (Bad_layout (ty,err)) @@ -2043,11 +2050,10 @@ let estimate_type_layout env typ = let type_layout env ty = estimate_type_layout env (get_unboxed_type_approximation env ty) -let type_sort ~reason env ty = +let type_sort ~why env ty = let sort = Sort.new_var () in match - constrain_type_layout ~reason:(Concrete_layout reason) - env ty (Layout.of_sort sort) + constrain_type_layout env ty (Layout.of_sort sort ~why) with | Ok _ -> Ok sort | Error _ as e -> e @@ -2072,16 +2078,16 @@ let rec intersect_type_layout ~reason env ty1 layout2 = Layout.intersection ~reason (estimate_type_layout env ty1) layout2 (* See comment on [layout_unification_mode] *) -let unification_layout_check ~reason env ty layout = +let unification_layout_check env ty layout = match !lmode with - | Perform_checks -> constrain_type_layout_exn ~reason env Unify ty layout + | Perform_checks -> constrain_type_layout_exn env Unify ty layout | Delay_checks r -> r := (ty,layout) :: !r | Skip_checks -> () let is_always_global env ty = let perform_check () = - Result.is_ok (check_type_layout ~reason:Dummy_reason_result_ignored - env ty Layout.immediate64) + Result.is_ok (check_type_layout env ty + (Layout.immediate64 ~why:Local_mode_cross_check)) in if !Clflags.principal || Env.has_local_constraints env then (* We snapshot to keep this pure; see the mode crossing test that mentions @@ -3042,8 +3048,8 @@ let unify_eq t1 t2 = && TypePairs.mem unify_eq_set (order_type_pair t1 t2)) let unify1_var env t1 t2 = - let name, layout = match get_desc t1 with - | Tvar { name; layout } -> name, layout + let layout = match get_desc t1 with + | Tvar { layout } -> layout | _ -> assert false in occur_for Unify env t1 t2; @@ -3056,19 +3062,18 @@ let unify1_var env t1 t2 = with Escape e -> raise_for Unify (Escape e) end; - unification_layout_check ~reason:(Unified_with_tvar name) env t2 layout; + unification_layout_check env t2 layout; link_type t1 t2; true | exception Unify_trace _ when in_pattern_mode () -> false (* Called from unify3 *) -let unify3_var ~var_name env layout1 t1' t2 t2' = +let unify3_var env layout1 t1' t2 t2' = occur_for Unify !env t1' t2; match occur_univar_for Unify !env t2 with | () -> begin - unification_layout_check ~reason:(Unified_with_tvar var_name) !env t2' - layout1; + unification_layout_check !env t2' layout1; link_type t1' t2 end | exception Unify_trace _ when in_pattern_mode () -> @@ -3218,10 +3223,10 @@ and unify3 env t1 t1' t2 t2' = if not (Layout.equal l1 l2) then raise_for Unify (Unequal_var_layouts (t1, l1, t2, l2)); link_type t1' t2' - | (Tvar { name; layout }, _) -> - unify3_var ~var_name:name env layout t1' t2 t2' - | (_, Tvar { name; layout }) -> - unify3_var ~var_name:name env layout t2' t1 t1' + | (Tvar { layout }, _) -> + unify3_var env layout t1' t2 t2' + | (_, Tvar { layout }) -> + unify3_var env layout t2' t1 t1' | (Tfield _, Tfield _) -> (* special case for GADTs *) unify_fields env t1' t2' | _ -> @@ -3408,7 +3413,8 @@ and make_rowvar level use1 rest1 use2 rest2 = | _ -> None in if use1 then rest1 else - if use2 then rest2 else newty2 ~level (Tvar { name; layout = Layout.value }) + if use2 then rest2 + else newty2 ~level (Tvar { name; layout = Layout.value ~why:Row_variable }) and unify_fields env ty1 ty2 = (* Optimization *) let (fields1, rest1) = flatten_fields ty1 @@ -3471,7 +3477,7 @@ and unify_row env row1 row2 = | None, Some _ -> rm2 | None, None -> newty2 ~level:(Int.min (get_level rm1) (get_level rm2)) - (Tvar { name = None; layout = Layout.value }) + (Tvar { name = None; layout = Layout.value ~why:Row_variable }) in let fixed = merge_fixed_explanation fixed1 fixed2 and closed = row1_closed || row2_closed in @@ -3677,15 +3683,14 @@ let unify_var ~from_subst env t1 t2 = match get_desc t1, get_desc t2 with Tvar _, Tconstr _ when deep_occur t1 t2 -> unify (ref env) t1 t2 - | Tvar { name; layout }, _ -> + | Tvar { layout }, _ -> let reset_tracing = check_trace_gadt_instances env in begin try occur_for Unify env t1 t2; update_level_for Unify env (get_level t1) t2; update_scope_for Unify (get_scope t1) t2; if not from_subst then begin - unification_layout_check ~reason:(Unified_with_tvar name) - env t2 layout + unification_layout_check env t2 layout end; link_type t1 t2; reset_trace_gadt_instances reset_tracing; @@ -3750,8 +3755,8 @@ let filter_arrow env t l ~force_tpoly = allow both to be any. Separately, the relevant checks on function arguments should happen when functions are constructed, not their types. *) - let l1 = Layout.of_new_sort_var () in - let l2 = Layout.of_new_sort_var () in + let l1 = Layout.of_new_sort_var ~why:Function_argument in + let l2 = Layout.of_new_sort_var ~why:Function_result in let t1 = if not force_tpoly then begin assert (not (is_optional l)); @@ -3762,7 +3767,8 @@ let filter_arrow env t l ~force_tpoly = newty2 ~level (* CR layouts v5: Change the Layout.value when option can hold non-values. *) - (Tconstr(Predef.path_option,[newvar2 level Layout.value], + (Tconstr(Predef.path_option, + [newvar2 level (Layout.value ~why:Type_argument)], ref Mnil)) else newvar2 level l1 @@ -3787,11 +3793,10 @@ let filter_arrow env t l ~force_tpoly = (Diff { got = t'; expected = t } :: trace)))) in match get_desc t with - Tvar { name; layout } -> + Tvar { layout } -> let t', marg, t1, mret, t2 = function_type (get_level t) in link_type t t'; - constrain_type_layout_exn ~reason:(Unified_with_tvar name) - env Unify t' layout; + constrain_type_layout_exn env Unify t' layout; (marg, t1, mret, t2) | Tarrow((l', marg, mret), t1, t2, _) -> if l = l' || !Clflags.classic && l = Nolabel && not (is_optional l') @@ -3824,15 +3829,15 @@ type filter_method_failure = | Unification_error of unification_error | Not_a_method | Not_an_object of type_expr - | Not_a_value of Layout.Violation.violation + | Not_a_value of Layout.Violation.t exception Filter_method_failed of filter_method_failure (* Used by [filter_method]. *) let rec filter_method_field env name ty = let method_type ~level = - let ty1 = newvar2 level Layout.value in - let ty2 = newvar2 level Layout.value in + let ty1 = newvar2 level (Layout.value ~why:Object_field) in + let ty2 = newvar2 level (Layout.value ~why:Row_variable) in let ty' = newty2 ~level (Tfield (name, field_public, ty1, ty2)) in ty', ty1 in @@ -3865,7 +3870,7 @@ let rec filter_method_field env name ty = (* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *) let filter_method env name ty = let object_type ~level ~scope = - let ty1 = newvar2 level Layout.value in + let ty1 = newvar2 level (Layout.value ~why:Row_variable) in let ty' = newty3 ~level ~scope (Tobject (ty1, ref None)) in let ty_meth = filter_method_field env name ty1 in (ty', ty_meth) @@ -3888,7 +3893,7 @@ let filter_method env name ty = let scope = get_scope ty in let ty', ty_meth = object_type ~level ~scope in begin match - constrain_type_layout ~reason:(Fixed_layout Object) env ty Layout.value + constrain_type_layout env ty (Layout.value ~why:Object) with | Ok _ -> () | Error err -> raise (Filter_method_failed (Not_a_value err)) @@ -3907,8 +3912,8 @@ let rec filter_method_row env name priv ty = match get_desc ty with | Tvar _ -> let level = get_level ty in - let field = newvar2 level Layout.value in - let row = newvar2 level Layout.value in + let field = newvar2 level (Layout.value ~why:Object_field) in + let row = newvar2 level (Layout.value ~why:Row_variable) in let kind, priv = match priv with | Private -> @@ -3944,7 +3949,7 @@ let rec filter_method_row env name priv ty = | Private -> let level = get_level ty in let kind = field_absent in - Mprivate kind, newvar2 level Layout.value, ty + Mprivate kind, newvar2 level (Layout.value ~why:Object_field), ty end | _ -> raise Filter_method_row_failed @@ -3952,7 +3957,7 @@ let rec filter_method_row env name priv ty = (* Operations on class signatures *) let new_class_signature () = - let row = newvar Layout.value in + let row = newvar (Layout.value ~why:Row_variable) in let self = newobj row in { csig_self = self; csig_self_row = row; @@ -4186,7 +4191,8 @@ let generalize_class_signature_spine env sign = in (* But keep levels correct on the type of self *) Meths.iter - (fun _ (_, _, ty) -> unify_var env (newvar Layout.value) ty) + (fun _ (_, _, ty) -> + unify_var env (newvar (Layout.value ~why:Object)) ty) meths; sign.csig_meths <- new_meths @@ -4277,13 +4283,12 @@ let rec moregen inst_nongen variance type_pairs env t1 t2 = try match (get_desc t1, get_desc t2) with - (Tvar { name; layout }, _) when may_instantiate inst_nongen t1 -> + (Tvar { layout }, _) when may_instantiate inst_nongen t1 -> moregen_occur env (get_level t1) t2; update_scope_for Moregen (get_scope t1) t2; occur_for Moregen env t1 t2; link_type t1 t2; - constrain_type_layout_exn ~reason:(Unified_with_tvar name) - env Moregen t2 layout + constrain_type_layout_exn env Moregen t2 layout | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> () | _ -> @@ -4295,12 +4300,11 @@ let rec moregen inst_nongen variance type_pairs env t1 t2 = if not (TypePairs.mem pairs (t1', t2')) then begin TypePairs.add pairs (t1', t2'); match (get_desc t1', get_desc t2') with - (Tvar { name; layout }, _) when may_instantiate inst_nongen t1' -> + (Tvar { layout }, _) when may_instantiate inst_nongen t1' -> moregen_occur env (get_level t1') t2; update_scope_for Moregen (get_scope t1') t2; link_type t1' t2; - constrain_type_layout_exn ~reason:(Unified_with_tvar name) - env Moregen t2 layout + constrain_type_layout_exn env Moregen t2 layout | (Tarrow ((l1,a1,r1), t1, u1, _), Tarrow ((l2,a2,r2), t2, u2, _)) when (l1 = l2 @@ -5266,8 +5270,12 @@ let rec build_subtype env (visited : transient_expr list) as this occurrence might break the occur check. XXX not clear whether this correct anyway... *) if List.exists (deep_occur ty) tl1 then raise Not_found; - set_type_desc ty (Tvar { name = None; layout = Layout.value }); - let t'' = newvar Layout.value in + set_type_desc ty + (Tvar { name = None; + layout = Layout.value + ~why:(Unknown "build subtype 1")}); + let t'' = newvar (Layout.value ~why:(Unknown "build subtype 2")) + in let loops = (get_id ty, t'') :: loops in (* May discard [visited] as level is going down *) let (ty1', c) = @@ -5306,7 +5314,9 @@ let rec build_subtype env (visited : transient_expr list) else build_subtype env visited loops (not posi) level t else if co then build_subtype env visited loops posi level t - else (newvar Layout.value, Changed)) + else (newvar (Layout.value + ~why:(Unknown "build_subtype 3")), + Changed)) decl.type_variance tl in let c = collect tl' in @@ -5343,7 +5353,7 @@ let rec build_subtype env (visited : transient_expr list) let c = collect fields in let row = create_row ~fields:(List.map fst fields) - ~more:(newvar Layout.value) + ~more:(newvar (Layout.value ~why:Row_variable)) ~closed:posi ~fixed:None ~name:(if c > Unchanged then None else row_name row) in @@ -5365,7 +5375,7 @@ let rec build_subtype env (visited : transient_expr list) else (t, Unchanged) | Tnil -> if posi then - let v = newvar Layout.value in + let v = newvar (Layout.value ~why:Tnil) in (v, Changed) else begin warn := true; @@ -5570,7 +5580,8 @@ and subtype_fields env trace ty1 ty2 cstrs = in let cstrs = if miss2 = [] then cstrs else - (trace, rest1, build_fields (get_level ty2) miss2 (newvar Layout.value), + (trace, rest1, build_fields (get_level ty2) miss2 + (newvar (Layout.value ~why:Object_field)), !univar_pairs) :: cstrs in List.fold_left @@ -5680,7 +5691,7 @@ let rec unalias_object ty = | Tunivar _ -> ty | Tconstr _ -> - newvar2 level Layout.value + newvar2 level (Layout.any ~why:Dummy_layout) | _ -> assert false @@ -5868,7 +5879,8 @@ let rec nondep_type_rec ?(expand_private=false) env ids ty = Tvar _ | Tunivar _ -> ty | _ -> try TypeHash.find nondep_hash ty with Not_found -> - let ty' = newgenstub ~scope:(get_scope ty) Layout.any in + let ty' = newgenstub ~scope:(get_scope ty) + (Layout.any ~why:Dummy_layout) in TypeHash.add nondep_hash ty ty'; match match get_desc ty with diff --git a/ocaml/typing/ctype.mli b/ocaml/typing/ctype.mli index 5a5f9759f51..6accc6f72f3 100644 --- a/ocaml/typing/ctype.mli +++ b/ocaml/typing/ctype.mli @@ -303,7 +303,7 @@ type filter_method_failure = | Unification_error of Errortrace.unification_error | Not_a_method | Not_an_object of type_expr - | Not_a_value of Layout.Violation.violation + | Not_a_value of Layout.Violation.t exception Filter_method_failed of filter_method_failure @@ -483,8 +483,8 @@ val type_layout : Env.t -> type_expr -> layout (* Find a type's sort (constraining it to be an arbitrary sort variable, if needed) *) val type_sort : - reason:Layouts.Layout.concrete_layout_reason -> - Env.t -> type_expr -> (sort, Layout.Violation.violation) result + why:Layouts.Layout.concrete_layout_reason -> + Env.t -> type_expr -> (sort, Layout.Violation.t) result (* Layout checking. [constrain_type_layout] will update the layout of type variables to make the check true, if possible. [check_decl_layout] and @@ -493,17 +493,11 @@ val type_sort : (* CR layouts: When we improve errors, it may be convenient to change these to raise on error, like unify. *) val check_decl_layout : - reason:Layouts.Layout.reason - -> Env.t -> type_declaration -> layout - -> (unit, Layout.Violation.violation) result + Env.t -> type_declaration -> layout -> (unit, Layout.Violation.t) result val check_type_layout : - reason:Layouts.Layout.reason - -> Env.t -> type_expr -> layout - -> (unit, Layout.Violation.violation) result + Env.t -> type_expr -> layout -> (unit, Layout.Violation.t) result val constrain_type_layout : - reason:Layouts.Layout.reason - -> Env.t -> type_expr -> layout - -> (unit, Layout.Violation.violation) result + Env.t -> type_expr -> layout -> (unit, Layout.Violation.t) result (* True if a type is always global (i.e., it mode crosses for local). This is true for all immediate and immediate64 types. To make it sound for diff --git a/ocaml/typing/datarepr.ml b/ocaml/typing/datarepr.ml index eba3333dcce..6f349ffa64a 100644 --- a/ocaml/typing/datarepr.ml +++ b/ocaml/typing/datarepr.ml @@ -70,7 +70,7 @@ let constructor_args ~current_unit priv cd_args cd_res path rep = let arg_vars_set = free_vars ~param:true (newgenty (Ttuple tyl)) in let type_params = TypeSet.elements arg_vars_set in let arity = List.length type_params in - let is_void_label lbl = Layout.is_void lbl.ld_layout in + let is_void_label lbl = Layout.is_void_defaulting lbl.ld_layout in let layout = Layout.for_boxed_record ~all_void:(List.for_all is_void_label lbls) in @@ -104,7 +104,7 @@ let constructor_descrs ~current_unit ty_path decl cstrs rep = | Variant_boxed layouts -> layouts | Variant_unboxed -> [| [| decl.type_layout |] |] in - let all_void layouts = Array.for_all Layout.is_void layouts in + let all_void layouts = Array.for_all Layout.is_void_defaulting layouts in let num_consts = ref 0 and num_nonconsts = ref 0 in let cstr_constant = Array.map @@ -197,7 +197,7 @@ let none = let dummy_label = { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable; lbl_global = Unrestricted; - lbl_layout = Layout.any; + lbl_layout = Layout.any ~why:Dummy_layout; lbl_num = -1; lbl_pos = -1; lbl_all = [||]; lbl_repres = Record_unboxed; lbl_private = Public; @@ -211,7 +211,7 @@ let label_descrs ty_res lbls repres priv = let rec describe_labels num pos = function [] -> [] | l :: rest -> - let is_void = Layout.is_void l.ld_layout in + let is_void = Layout.is_void_defaulting l.ld_layout in let lbl = { lbl_name = Ident.name l.ld_id; lbl_res = ty_res; diff --git a/ocaml/typing/errortrace.ml b/ocaml/typing/errortrace.ml index 2ecc3591d74..2b52aaf724e 100644 --- a/ocaml/typing/errortrace.ml +++ b/ocaml/typing/errortrace.ml @@ -109,8 +109,8 @@ type ('a, 'variety) elt = (* Could move [Incompatible_fields] into [obj] *) (* Unification & Moregen; included in Equality for simplicity *) | Rec_occur : type_expr * type_expr -> ('a, _) elt - | Bad_layout : type_expr * Layout.Violation.violation -> ('a, _) elt - | Bad_layout_sort : type_expr * Layout.Violation.violation -> ('a, _) elt + | Bad_layout : type_expr * Layout.Violation.t -> ('a, _) elt + | Bad_layout_sort : type_expr * Layout.Violation.t -> ('a, _) elt | Unequal_var_layouts : type_expr * layout * type_expr * layout -> ('a, _) elt diff --git a/ocaml/typing/errortrace.mli b/ocaml/typing/errortrace.mli index d70eacf5d6e..0d9683292d7 100644 --- a/ocaml/typing/errortrace.mli +++ b/ocaml/typing/errortrace.mli @@ -94,8 +94,8 @@ type ('a, 'variety) elt = | Incompatible_fields : { name:string; diff: type_expr diff } -> ('a, _) elt (* Unification & Moregen; included in Equality for simplicity *) | Rec_occur : type_expr * type_expr -> ('a, _) elt - | Bad_layout : type_expr * Layout.Violation.violation -> ('a, _) elt - | Bad_layout_sort : type_expr * Layout.Violation.violation -> ('a, _) elt + | Bad_layout : type_expr * Layout.Violation.t -> ('a, _) elt + | Bad_layout_sort : type_expr * Layout.Violation.t -> ('a, _) elt | Unequal_var_layouts : type_expr * layout * type_expr * layout -> ('a, _) elt diff --git a/ocaml/typing/includecore.ml b/ocaml/typing/includecore.ml index 1b1bdebc62f..f0ac0c44b2d 100644 --- a/ocaml/typing/includecore.ml +++ b/ocaml/typing/includecore.ml @@ -230,7 +230,7 @@ type type_mismatch = | Variant_mismatch of variant_change list | Unboxed_representation of position * attributes | Extensible_representation of position - | Layout of Layout.Violation.violation + | Layout of Layout.Violation.t let report_locality_mismatch first second ppf err = let {order; nonlocal} = err in @@ -1006,10 +1006,7 @@ let type_declarations ?(equality = false) ~loc env ~mark name have a manifest, which we're already checking for equality above. Similarly, [decl1]'s kind may conservatively approximate its layout, but [check_decl_layout] will expand its manifest. *) - (match - Ctype.check_decl_layout ~reason:Dummy_reason_result_ignored - env decl1 decl2.type_layout - with + (match Ctype.check_decl_layout env decl1 decl2.type_layout with | Ok _ -> None | Error v -> Some (Layout v)) | (Type_variant (cstrs1, rep1), Type_variant (cstrs2, rep2)) -> diff --git a/ocaml/typing/includecore.mli b/ocaml/typing/includecore.mli index f727ea587e2..5cc40993103 100644 --- a/ocaml/typing/includecore.mli +++ b/ocaml/typing/includecore.mli @@ -108,7 +108,7 @@ type type_mismatch = | Variant_mismatch of variant_change list | Unboxed_representation of position * attributes | Extensible_representation of position - | Layout of Layout.Violation.violation + | Layout of Layout.Violation.t val value_descriptions: loc:Location.t -> Env.t -> string -> diff --git a/ocaml/typing/layouts.ml b/ocaml/typing/layouts.ml index 08632074b3a..9f927236573 100644 --- a/ocaml/typing/layouts.ml +++ b/ocaml/typing/layouts.ml @@ -12,6 +12,11 @@ (* *) (**************************************************************************) +type sub_result = + | Equal + | Sub + | Not_sub + (* Layouts *) module Sort = struct @@ -40,6 +45,8 @@ module Sort = struct let void = Const Void let value = Const Value + let some_value = Some value + let of_const = function | Void -> void | Value -> value @@ -77,6 +84,8 @@ module Sort = struct end end + let default_to_value t = ignore (get_default_value t) + (***********************) (* equality *) @@ -128,6 +137,29 @@ module Sort = struct | Unequal -> false | Equal_mutated_first | Equal_mutated_second | Equal_no_mutation -> true + let rec is_void_defaulting = function + | Const Void -> true + | Var v -> begin match !v with + (* CR layouts v5: this should probably default to void now *) + | None -> v := some_value; false + | Some s -> is_void_defaulting s + end + | Const Value -> false + + (*** pretty printing ***) + + let string_of_const = function + | Value -> "value" + | Void -> "void" + + let to_string s = match get s with + | Var v -> var_name v + | Const c -> string_of_const c + + let format ppf t = Format.fprintf ppf "%s" (to_string t) + + (*** debug printing **) + module Debug_printers = struct open Format @@ -148,8 +180,23 @@ end type sort = Sort.t module Layout = struct - type fixed_layout_reason = + (*** reasons for layouts **) + + type concrete_layout_reason = + | Match + | Constructor_declaration of int + | Label_declaration of Ident.t + | Unannotated_type_parameter + | Record_projection + | Record_assignment | Let_binding + | Function_argument + | Function_result + | Structure_item_expression + | V1_safety_check + + type value_creation_reason = + | Class_let_binding | Tuple_element | Probe | Package_hack @@ -157,31 +204,82 @@ module Layout = struct | Instance_variable | Object_field | Class_field + | Boxed_record + | Boxed_variant + | Extensible_variant + | Primitive of Ident.t + | Type_argument + | Tuple + | Row_variable + | Polymorphic_variant + | Arrow + | Tfield + | Tnil + | First_class_module + | Separability_check + | Univar + | Polymorphic_variant_field + | Default_type_layout + | Float_record_field + | Existential_type_variable + | Array_element + | Lazy_expression + | Class_argument + | Structure_element + | Debug_printer_argument + | V1_safety_check + | Unknown of string + + type immediate_creation_reason = + | Empty_record + | Enumeration + | Primitive of Ident.t + | Immediate_polymorphic_variant + | Gc_ignorable_check + | Value_kind + + type immediate64_creation_reason = + | Local_mode_cross_check + | Gc_ignorable_check + | Separability_check + + type void_creation_reason = + | V1_safety_check - type concrete_layout_reason = - | Match - | Constructor_declaration of int - | Label_declaration of Ident.t - | Function_argument - | Function_result + type any_creation_reason = + | Missing_cmi of Path.t + | Wildcard + | Unification_var + | Initial_typedecl_env + | Dummy_layout + | Type_expression_call - type annotation_location = + type annotation_context = | Type_declaration of Path.t | Type_parameter of Path.t * string - | With_constraint of Location.t - | Newtype_declaration of string Location.loc - - type reason = - | Fixed_layout of fixed_layout_reason - | Concrete_layout of concrete_layout_reason - | Annotated of annotation_location + | With_constraint of string + | Newtype_declaration of string + + type creation_reason = + | Annotated of annotation_context * Location.t + | Value_creation of value_creation_reason + | Immediate_creation of immediate_creation_reason + | Immediate64_creation of immediate64_creation_reason + | Void_creation of void_creation_reason + | Any_creation of any_creation_reason + | Concrete_creation of concrete_layout_reason + | Imported + + type interact_reason = | Gadt_equation of Path.t - | Unified_with_tvar of string option - | V1_safety_check - | Dummy_reason_result_ignored + | Tyvar_refinement_intersection + (* CR layouts: this needs to carry a type_expr, but that's loopy *) + | Sublayout + + (*** actual layout types ***) type internal = - | Any of { missing_cmi_for : Path.t option } + | Any | Sort of sort | Immediate64 (** We know for sure that values of types of this layout are always immediate @@ -189,25 +287,48 @@ module Layout = struct *) | Immediate + (* A history of conditions placed on a layout. + + INVARIANT: at most one sort variable appears in this history. + This is a natural consequence of producing this history by comparing + layouts. + *) + type history = + | Interact of { reason : interact_reason + ; lhs_layout : internal + ; lhs_history : history + ; rhs_layout : internal + ; rhs_history : history + } + | Creation of creation_reason + type t = { layout : internal - ; history : reason list (* events listed in reverse chronological order *) - } - - let fresh_layout layout = { layout; history = [] } + ; history : history } - let add_reason reason t = { t with history = reason :: t.history } + let fresh_layout layout ~why = { layout; history = Creation why } (******************************) (* constants *) - let any' missing_cmi_for = fresh_layout (Any { missing_cmi_for }) - let any = any' None - let missing_cmi_any type_ = any' (Some type_) - let void = fresh_layout (Sort Sort.void) - let value = fresh_layout (Sort Sort.value) - let immediate64 = fresh_layout Immediate64 - let immediate = fresh_layout Immediate + let any_dummy_layout = + { layout = Any; history = Creation (Any_creation Dummy_layout) } + let value_v1_safety_check = + { layout = Sort Sort.value; + history = Creation (Value_creation V1_safety_check) } + + let any ~why = match why with + | Dummy_layout -> any_dummy_layout (* share this one common case *) + | _ -> fresh_layout Any ~why:(Any_creation why) + let void ~why = + fresh_layout (Sort Sort.void) ~why:(Void_creation why) + let value ~(why : value_creation_reason) = match why with + | V1_safety_check -> value_v1_safety_check + | _ -> fresh_layout (Sort Sort.value) ~why:(Value_creation why) + let immediate64 ~why = + fresh_layout Immediate64 ~why:(Immediate64_creation why) + let immediate ~why = + fresh_layout Immediate ~why:(Immediate_creation why) type const = Asttypes.const_layout = | Any @@ -231,25 +352,35 @@ module Layout = struct | Value, Value -> true | (Any | Immediate64 | Immediate | Void | Value), _ -> false - (******************************) + let sub_const (c1 : const) (c2 : const) = match c1, c2 with + | Any, Any -> Equal + | _, Any -> Sub + | c1, c2 when equal_const c1 c2 -> Equal + | (Immediate | Immediate64), Value -> Sub + | Immediate, Immediate64 -> Sub + | (Any | Void | Value | Immediate64 | Immediate), _ -> Not_sub + + (******************************) (* construction *) - let of_new_sort_var () = fresh_layout (Sort (Sort.new_var ())) + let of_new_sort_var ~why = + fresh_layout (Sort (Sort.new_var ())) ~why:(Concrete_creation why) - let of_sort s = fresh_layout (Sort s) + let of_sort ~why s = + fresh_layout (Sort s) ~why:(Concrete_creation why) - let of_const : const -> t = function - | Any -> any - | Immediate -> immediate - | Immediate64 -> immediate64 - | Value -> value - | Void -> void + let of_const ~why : const -> t = function + | Any -> fresh_layout Any ~why + | Immediate -> fresh_layout Immediate ~why + | Immediate64 -> fresh_layout Immediate64 ~why + | Value -> fresh_layout (Sort Sort.value) ~why + | Void -> fresh_layout (Sort Sort.void) ~why let of_attributes ~legacy_immediate ~reason attrs = - Result.map (Option.map (add_reason (Annotated reason))) @@ match Builtin_attributes.layout ~legacy_immediate attrs with | Ok None as a -> a - | Ok (Some l) -> Ok (Some (of_const l)) + | Ok (Some l) -> Ok (Some (of_const ~why:(Annotated (reason, l.loc)) + l.txt)) | Error _ as e -> e let of_attributes_default ~legacy_immediate ~reason ~default attrs = @@ -259,7 +390,10 @@ module Layout = struct | Error _ as e -> e let for_boxed_record ~all_void = - if all_void then immediate else value + if all_void then immediate ~why:Empty_record else value ~why:Boxed_record + + let for_boxed_variant ~all_voids = + if all_voids then immediate ~why:Enumeration else value ~why:Boxed_variant (******************************) (* elimination and defaulting *) @@ -268,12 +402,21 @@ module Layout = struct | Const of const | Var of Sort.var - let of_desc = function - | Const c -> of_const c - | Var v -> of_sort (Sort.of_var v) - - let get (t : t) : desc = match t.layout with - | Any _ -> Const Any + let format_desc ppf = let open Format in function + | Const c -> fprintf ppf "%s" (string_of_const c) + | Var v -> fprintf ppf "%s" (Sort.var_name v) + + (* considers sort variables < Any, but otherwise just checks for equality. + Never does mutation. + Pre-condition: no filled-in sort variables. *) + let sub_desc d1 d2 = match d1, d2 with + | Const c1, Const c2 -> sub_const c1 c2 + | Var _, Const Any -> Sub + | Var v1, Var v2 -> if v1 == v2 then Equal else Not_sub + | Const _, Var _ | Var _, Const _ -> Not_sub + + let get_internal (lay : internal) : desc = match lay with + | Any -> Const Any | Immediate -> Const Immediate | Immediate64 -> Const Immediate64 | Sort s -> begin match Sort.get s with @@ -285,7 +428,7 @@ module Layout = struct end let get_default_value (t : t) : const = match t.layout with - | Any _ -> Any + | Any -> Any | Immediate -> Immediate | Immediate64 -> Immediate64 | Sort s -> begin match Sort.get_default_value s with @@ -296,7 +439,7 @@ module Layout = struct let default_to_value t = ignore (get_default_value t) - let is_void t = Void = get_default_value t + let get t = get_internal t.layout (* CR layouts: this function is suspect; it seems likely to reisenberg that refactoring could get rid of it *) @@ -314,38 +457,77 @@ module Layout = struct | Const c -> string_of_const c | Var v -> Sort.var_name v - module Formatting : sig - open Format - val format : formatter -> t -> unit - val format_history : - pp_name:(formatter -> 'a -> unit) -> name:'a -> - formatter -> t -> unit + let format ppf t = Format.fprintf ppf "%s" (to_string t) + + (***********************************) + (* layout histories *) + + let printtyp_path = ref (fun _ _ -> assert false) + let set_printtyp_path f = printtyp_path := f + + module Report_missing_cmi : sig + (* used both in format_history and in Violation.report_general *) + val report_missing_cmi : Format.formatter -> Path.t option -> unit end = struct open Format - let format ppf t = fprintf ppf "%s" (to_string t) + (* CR layouts: Remove this horrible (but useful) heuristic once we have + transitive dependencies in jenga. *) + let missing_cmi_hint ppf type_path = + let root_module_name p = p |> Path.head |> Ident.name in + let delete_trailing_double_underscore s = + if Misc.Stdlib.String.ends_with ~suffix:"__" s + then String.sub s 0 (String.length s - 2) + else s + in + (* A heuristic for guessing at a plausible library name for an identifier + with a missing .cmi file; definitely less likely to be right outside of + Jane Street. *) + let guess_library_name : Path.t -> string option = function + | Pdot _ as p -> Some begin + match root_module_name p with + | "Location" | "Longident" -> "ocamlcommon" + | mn -> mn + |> String.lowercase_ascii + |> delete_trailing_double_underscore + end + | Pident _ | Papply _ -> + None + in + Option.iter + (fprintf ppf "@,Hint: Adding \"%s\" to your dependencies might help.") + (guess_library_name type_path) + + let report_missing_cmi ppf = function + | Some p -> + fprintf ppf "@,No .cmi file found containing %a." !printtyp_path p; + missing_cmi_hint ppf p + | None -> () + end - let fixed_layout_reason_layout = function - | Let_binding - | Tuple_element - | Probe - | Package_hack - | Object - | Instance_variable - | Object_field - | Class_field - -> value + include Report_missing_cmi - let format_fixed_layout_reason ppf = - function - | Let_binding -> fprintf ppf "let-bound" - | Tuple_element -> fprintf ppf "a tuple element" - | Probe -> fprintf ppf "a probe" - | Package_hack -> fprintf ppf "used as a value in a first-class module" - | Object -> fprintf ppf "an object" - | Instance_variable -> fprintf ppf "an instance variable" - | Object_field -> fprintf ppf "an object field" - | Class_field -> fprintf ppf "an class field" + (* CR layouts: should this be configurable? In the meantime, you + may want to change these to experiment / debug. *) + + (* should we print histories at all? *) + let display_histories = false + + (* should we print histories in a way users can understand? + The alternative is to print out all the data, which may be useful + during debugging. *) + let flattened_histories = true + + (* This module is just to keep all the helper functions more locally + scoped. *) + module Format_history : sig + val format_history : + intro:(Format.formatter -> unit) -> Format.formatter -> t -> unit + end = struct + (* CR layouts: all the output in this section is subject to change; + actually look closely at error messages once this is activated *) + + open Format let format_concrete_layout_reason ppf : concrete_layout_reason -> unit = function @@ -356,67 +538,253 @@ module Layout = struct | Label_declaration lbl -> fprintf ppf "used in the declaration of the record field \"%a\"" Ident.print lbl - | Function_argument -> fprintf ppf "a function argument" - | Function_result -> fprintf ppf "a function result" + | Unannotated_type_parameter -> + fprintf ppf "appears as an unannotated type parameter" + | Record_projection -> + fprintf ppf "used as the record in a projection" + | Record_assignment -> + fprintf ppf "used as the record in an assignment" + | Let_binding -> + fprintf ppf "bound by a `let`" + | Function_argument -> + fprintf ppf "used as a function argument" + | Function_result -> + fprintf ppf "used as a function result" + | Structure_item_expression -> + fprintf ppf "used in an expression in a structure" + | V1_safety_check -> + fprintf ppf "part of the v1 safety check" - let format_annotation_location ppf : annotation_location -> unit = function + let format_annotation_context ppf : annotation_context -> unit = function | Type_declaration p -> fprintf ppf "the declaration of the type %a" - Path.print p - | Type_parameter (p, var) -> - fprintf ppf "%s@ in the declaration of the type %a" + !printtyp_path p + | Type_parameter (path, var) -> + fprintf ppf "@[%s@ in the declaration of the type@ %a@]" var - Path.print p - | With_constraint loc -> - fprintf ppf "the `with` constraint at %a" - Location.print_loc loc - | Newtype_declaration {loc; txt} -> - fprintf ppf "the abstract type declaration for %s at %a" - txt Location.print_loc loc - - let format_reason ppf : reason -> unit = function - | Fixed_layout flr -> - fprintf ppf "to@ %a because it was@ %a" - format (fixed_layout_reason_layout flr) - format_fixed_layout_reason flr - | Concrete_layout clr -> - fprintf ppf "to be concrete@ because it was %a" - format_concrete_layout_reason clr - | Annotated aloc -> - fprintf ppf "by the annotation@ on %a" - format_annotation_location aloc - | Gadt_equation p -> - fprintf ppf "by a GADT match@ on the constructor %a" - Path.print p - | Unified_with_tvar tv -> begin - fprintf ppf "during unification@ with "; - match tv with - | None -> fprintf ppf "a type variable" - | Some tv -> fprintf ppf "'%s" tv - end + !printtyp_path path + | With_constraint s -> + fprintf ppf "the `with` constraint for %s" s + | Newtype_declaration name -> + fprintf ppf "the abstract type declaration for %s" + name + + let format_any_creation_reason ppf : any_creation_reason -> unit = function + | Missing_cmi p -> + fprintf ppf "a missing .cmi file for %a" !printtyp_path p + | Wildcard -> + fprintf ppf "a _ in a type" + | Unification_var -> + fprintf ppf "a fresh unification variable" + | Initial_typedecl_env -> + fprintf ppf "a dummy layout used in checking mutually recursive datatypes" + | Dummy_layout -> + fprintf ppf "@[a dummy layout that should have been overwritten;@ \ + Please notify the Jane Street compilers group if you see this output." + (* CR layouts: Improve output or remove this constructor ^^ *) + | Type_expression_call -> + fprintf ppf "a call to [type_expression] via the ocaml API" + + let format_immediate_creation_reason ppf : immediate_creation_reason -> _ = + function + | Empty_record -> + fprintf ppf "a record containing all void elements" + | Enumeration -> + fprintf ppf "an enumeration variant (all constructors are constant)" + | Primitive id -> + fprintf ppf "it equals the primitive immediate type %s" (Ident.name id) + | Immediate_polymorphic_variant -> + fprintf ppf "an immediate polymorphic variant" + | Gc_ignorable_check -> + fprintf ppf "the check to see whether a value can be ignored by GC" + | Value_kind -> + fprintf ppf + "the check to see whether a polymorphic variant is immediate" + + let format_immediate64_creation_reason ppf = function + | Local_mode_cross_check -> + fprintf ppf "the check for whether a local value can safely escape" + | Gc_ignorable_check -> + fprintf ppf "the check to see whether a value can be ignored by GC" + | Separability_check -> + fprintf ppf "the check that a type is definitely not `float`" + + let format_value_creation_reason ppf : value_creation_reason -> _ = function + | Class_let_binding -> fprintf ppf "let-bound in a class expression" + | Tuple_element -> fprintf ppf "a tuple element" + | Probe -> fprintf ppf "a probe" + | Package_hack -> fprintf ppf "used as an element in a first-class module" + | Object -> fprintf ppf "an object" + | Instance_variable -> fprintf ppf "an instance variable" + | Object_field -> fprintf ppf "an object field" + | Class_field -> fprintf ppf "an class field" + | Boxed_record -> fprintf ppf "a boxed record" + | Boxed_variant -> fprintf ppf "a boxed variant" + | Extensible_variant -> fprintf ppf "an extensible variant" + | Primitive id -> + fprintf ppf "it equals the primitive value type %s" (Ident.name id) + | Type_argument -> fprintf ppf "a type argument defaulted to have layout value" + | Tuple -> fprintf ppf "a tuple type" + | Row_variable -> fprintf ppf "a row variable" + | Polymorphic_variant -> fprintf ppf "a polymorphic variant" + | Arrow -> fprintf ppf "a function type" + | Tfield -> fprintf ppf "an internal Tfield type (you shouldn't see this)" + | Tnil -> fprintf ppf "an internal Tnil type (you shouldn't see this)" + | First_class_module -> fprintf ppf "a first-class module type" + | Separability_check -> + fprintf ppf "the check that a type is definitely not `float`" + | Univar -> fprintf ppf "an unannotated universal variable" + | Polymorphic_variant_field -> fprintf ppf "a field of a polymorphic variant" + | Default_type_layout -> + fprintf ppf "the default layout for an abstract type" + | Float_record_field -> + fprintf ppf "a field of a float record" + | Existential_type_variable -> + fprintf ppf "an unannotated existential type variable" + | Array_element -> + fprintf ppf "an array element" + | Lazy_expression -> + fprintf ppf "a lazy expression" + | Class_argument -> + fprintf ppf "a term-level argument to a class constructor" + | Structure_element -> + fprintf ppf "stored in a module structure" + | Debug_printer_argument -> + fprintf ppf "used as the argument to a debugger printer function" | V1_safety_check -> fprintf ppf "to be value for the V1 safety check" - | Dummy_reason_result_ignored -> - Misc.fatal_errorf - "Found [Dummy_reason_result_ignored] in a [layout] when printing!" - - let format_history ~pp_name ~name ppf t = - (* CR layouts: Re-do this whole facility with a tree structure *) - if false then begin - let message ppf = function - | 0 -> fprintf ppf "%a's layout was constrained" pp_name name - | _ -> fprintf ppf "and" + | Unknown s -> fprintf ppf "unknown @[(please alert the Jane Street@;\ + compilers team with this message: %s)@]" s + + + let format_void_creation_reason ppf : void_creation_reason -> _ = function + | V1_safety_check -> fprintf ppf "check to make sure there are no voids" + (* CR layouts: remove this when we remove its uses *) + + let format_creation_reason ppf : creation_reason -> unit = function + | Annotated (ctx, _) -> + fprintf ppf "of the annotation on %a" format_annotation_context ctx + | Any_creation any -> + format_any_creation_reason ppf any + | Immediate_creation immediate -> + format_immediate_creation_reason ppf immediate + | Immediate64_creation immediate64 -> + format_immediate64_creation_reason ppf immediate64 + | Void_creation void -> + format_void_creation_reason ppf void + | Value_creation value -> + format_value_creation_reason ppf value + | Concrete_creation concrete -> + format_concrete_layout_reason ppf concrete + | Imported -> + fprintf ppf "imported from another compilation unit" + + let format_interact_reason ppf = function + | Gadt_equation name -> + fprintf ppf "a GADT match on the constructor %a" !printtyp_path name + | Tyvar_refinement_intersection -> + fprintf ppf "updating a type variable" + | Sublayout -> + fprintf ppf "sublayout check" + + (* a flattened_history describes the history of a layout L. That + layout has been constrained to be a sublayout of layouts L1..Ln. + Each element in a flattened_history includes a layout desc Li and the + set of circumstances that gave rise to a constraint of that layout. + Any layouts Lk such that an Li < Lk doesn't contribute to the choice + of L and is thus omitted from a flattened_history. + + INVARIANT: the creation_reasons within a list all are reasons for + the layout they are paired with. + INVARIANT: L is a sublayout of all the Li in a flattened_history. + INVARIANT: If Li and Lj are stored in different entries in a + flattened_history, then not (Li <= Lj) and not (Lj <= Li). + This implies that no two elements in a flattened_history have the + same layout in them. + INVARIANT: no list in this structure is empty + + Both levels of list are unordered. + + Because a flattened_history stores [desc]s, it should be discarded + promptly after use. + + This type could be more efficient in several ways, but there is + little incentive to do so. *) + type flattened_row = desc * creation_reason list + type flattened_history = flattened_row list + + (* first arg is the layout L whose history we are flattening *) + let flatten_history : internal -> history -> flattened_history = + let add layout reason = + let layout_desc = get_internal layout in + let rec go acc = function + | ((key, value) as row) :: rest -> + begin match sub_desc layout_desc key with + | Sub -> go acc rest + | Equal -> (key, reason :: value) :: acc @ rest + | Not_sub -> go (row :: acc) rest + end + | [] -> (layout_desc, [reason]) :: acc + in + go [] + in + let rec history acc internal = function + | Interact { reason = _ + ; lhs_layout + ; lhs_history + ; rhs_layout + ; rhs_history } -> + let fh1 = history acc lhs_layout lhs_history in + let fh2 = history fh1 rhs_layout rhs_history in + fh2 + | Creation reason -> + add internal reason acc in - List.iteri - (fun i r -> - fprintf ppf "@,@[%a %a@]" - message i - format_reason r) - t.history + fun internal hist -> + history [] internal hist + + let format_flattened_row ppf (lay, reasons) = + fprintf ppf "%a, because" format_desc lay; + match reasons with + | [reason] -> fprintf ppf "@ %a." format_creation_reason reason + | _ -> + fprintf ppf " all of the following:@ @[ %a@]" + (pp_print_list format_creation_reason) reasons + + let format_flattened_history ~intro ppf t = + let fh = flatten_history t.layout t.history in + fprintf ppf "@[%t " intro; + begin match fh with + | [row] -> format_flattened_row ppf row + | _ -> fprintf ppf "a sublayout of all of the following:@ @[ %a@]" + (pp_print_list format_flattened_row) fh + end; + fprintf ppf "@]@;" + + (* this isn't really formatted for user consumption *) + let format_history_tree ~intro ppf t = + let rec in_order ppf = function + | Interact { reason; lhs_history; rhs_history } -> + fprintf ppf "@[ %a@]@;%a@ @[ %a@]" + in_order lhs_history + format_interact_reason reason + in_order rhs_history + | Creation c -> + format_creation_reason ppf c + in + fprintf ppf "@;%t has this layout history:@;@[ %a@]" + intro + in_order t.history + + let format_history ~intro ppf t = + if display_histories then begin + if flattened_histories + then format_flattened_history ~intro ppf t + else format_history_tree ~intro ppf t end end - include Formatting + include Format_history (******************************) (* errors *) @@ -424,125 +792,64 @@ module Layout = struct module Violation = struct open Format - let printtyp_path = ref (fun _ _ -> assert false) - - let set_printtyp_path f = printtyp_path := f - - type message = + type violation = | Not_a_sublayout of t * t | No_intersection of t * t - type violation = - { message : message - ; missing_cmi : bool } - - let derive_missing_cmi l1 l2 = - let missing_cmi l = - match l.layout with - | Any { missing_cmi_for = Some _ } -> - true - | Any { missing_cmi_for = None } | Sort _ | Immediate64 | Immediate -> - false - in - missing_cmi l1 || missing_cmi l2 - - let not_a_sublayout l1 l2 = - { message = Not_a_sublayout (l1, l2) - ; missing_cmi = derive_missing_cmi l1 l2 - } - - let no_intersection l1 l2 = - { message = No_intersection (l1, l2) - ; missing_cmi = derive_missing_cmi l1 l2 - } - - let add_missing_cmi_for ~missing_cmi_for = function - | { layout = Any { missing_cmi_for = None }; history } -> - { layout = Any { missing_cmi_for = Some missing_cmi_for }; history } - | t -> t - - let add_missing_cmi_for_lhs ~missing_cmi_for t = - { message = begin match t.message with - | Not_a_sublayout (lhs, rhs) -> - Not_a_sublayout (add_missing_cmi_for ~missing_cmi_for lhs, rhs) - | No_intersection (lhs, rhs) -> - No_intersection (add_missing_cmi_for ~missing_cmi_for lhs, rhs) - end - ; missing_cmi = true - (* CR layouts: If we decide to keep the [missing_cmi] field, we should - think about whether this function ought to check if - [add_missing_cmi_for] did anything. *) - } + type nonrec t = { violation : violation + ; missing_cmi : Path.t option } + (* [missing_cmi]: is this error a result of a missing cmi file? + This is stored separately from the [violation] because it's + used to change the behavior of [value_kind], and we don't + want that function to inspect something that is purely about + the choice of error message. (Though the [Path.t] payload *is* + indeed just about the payload.) *) - let missing_cmi_hint ppf type_path = - let root_module_name p = p |> Path.head |> Ident.name in - let delete_trailing_double_underscore s = - if Misc.Stdlib.String.ends_with ~suffix:"__" s - then String.sub s 0 (String.length s - 2) - else s - in - (* A heuristic for guessing at a plausible library name for an identifier - with a missing .cmi file; definitely less likely to be right outside of - Jane Street. *) - let guess_library_name : Path.t -> string option = function - | Pdot _ as p -> Some begin - match root_module_name p with - | "Location" | "Longident" -> "ocamlcommon" - | mn -> mn - |> String.lowercase_ascii - |> delete_trailing_double_underscore - end - | Pident _ | Papply _ -> - None - in - Option.iter - (fprintf ppf "@,Hint: Adding \"%s\" to your dependencies might help.") - (guess_library_name type_path) + let of_ violation = { violation; missing_cmi = None } - let report_missing_cmi ppf = function - | { layout = Any { missing_cmi_for = Some p }; _ } -> - fprintf ppf "@,No .cmi file found containing %a.%a" - (!printtyp_path) p - missing_cmi_hint p - | _ -> () - - type problem = - | Is_not_representable - | Is_not_a_sublayout_of - | Does_not_overlap_with - - let message = function - | Is_not_representable -> "is not representable" - | Is_not_a_sublayout_of -> "is not a sublayout of" - | Does_not_overlap_with -> "does not overlap with" - - let report_second = function - | Is_not_representable -> - fun _ _ -> () - | Is_not_a_sublayout_of | Does_not_overlap_with -> - fun ppf -> fprintf ppf " %a" format + let record_missing_cmi ~missing_cmi_for t = { t with missing_cmi = Some missing_cmi_for } + + let is_missing_cmi { missing_cmi } = Option.is_some missing_cmi let report_general preamble pp_former former ppf t = - let l1, problem, l2 = match t.message with - | Not_a_sublayout(l1, l2) -> - l1, - (match get l2 with - | Var _ -> Is_not_representable - | Const _ -> Is_not_a_sublayout_of), - l2 - | No_intersection(l1, l2) -> - l1, Does_not_overlap_with, l2 + let sublayout_format verb l2 = match get l2 with + | Var _ -> dprintf "%s representable" verb + | Const _ -> dprintf "%s a sublayout of %a" verb format l2 + in + let l1, l2, fmt_l1, fmt_l2, missing_cmi_option = match t with + | { violation = Not_a_sublayout(l1, l2); missing_cmi } -> + begin match missing_cmi with + | None -> + l1, l2, + dprintf "layout %a" format l1, + sublayout_format "is not" l2, None + | Some p -> + l1, l2, + dprintf "an unknown layout", + sublayout_format "might not be" l2, Some p + end + | { violation = No_intersection(l1, l2); missing_cmi } -> + assert (Option.is_none missing_cmi); + l1, l2, + dprintf "layout %a" format l1, + dprintf "does not overlap with %a" format l2, None in - fprintf ppf "@[@[%s%a has layout %a,@ which %s%a.@]%a%a%a%a@]" - preamble - pp_former former - format l1 - (message problem) - (report_second problem) l2 - (format_history ~pp_name:pp_former ~name:former) l1 - (format_history ~pp_name:pp_print_string ~name:"The latter") l2 - report_missing_cmi l1 - report_missing_cmi l2 + if display_histories then begin + let connective = match t.violation with + | Not_a_sublayout _ -> "be a sublayout of" + | No_intersection _ -> "overlap with" + in + fprintf ppf "%a%a" + (format_history ~intro:(dprintf "The layout of %a is" pp_former former)) l1 + (format_history ~intro:(dprintf "But the layout of %a must %s" pp_former former connective)) l2; + end else begin + fprintf ppf "@[%s%a has %t,@ which %t.@]" + preamble + pp_former former + fmt_l1 + fmt_l2 + end; + report_missing_cmi ppf missing_cmi_option let pp_t ppf x = fprintf ppf "%t" x @@ -554,14 +861,14 @@ module Layout = struct let report_with_name ~name = report_general "" pp_print_string name -end + end (******************************) (* relations *) let equate_or_equal ~allow_mutation (l1 : t) (l2 : t) = match l1.layout, l2.layout with - | Any _, Any _ -> true + | Any, Any -> true | Immediate64, Immediate64 -> true | Immediate, Immediate -> true | Sort s1, Sort s2 -> begin @@ -573,42 +880,74 @@ end | Unequal -> false | Equal_no_mutation | Equal_mutated_first | Equal_mutated_second -> true end - | (Any _ | Immediate64 | Immediate | Sort _), _ -> false + | (Any | Immediate64 | Immediate | Sort _), _ -> false (* CR layouts v2: Switch this back to ~allow_mutation:false *) let equal = equate_or_equal ~allow_mutation:true let equate = equate_or_equal ~allow_mutation:true + let combine_histories reason lhs rhs = + Interact { reason; lhs_layout = lhs.layout; lhs_history = lhs.history; + rhs_layout = rhs.layout; rhs_history = rhs.history } + let intersection ~reason l1 l2 = - let err = Error (Violation.no_intersection l1 l2) in - let equality_check is_eq l = if is_eq then Ok l else err in - (* it's OK not to cache the result of [get], because [get] does path - compression *) - Result.map (add_reason reason) @@ match get l1, get l2 with - | Const Any, _ -> Ok { layout = l2.layout; history = l1.history } - | _, Const Any -> Ok l1 - | Const c1, Const c2 when equal_const c1 c2 -> Ok l1 - | Const (Immediate64 | Immediate), Const (Immediate64 | Immediate) -> - Ok immediate - | Const ((Immediate64 | Immediate) as imm), l - | l, Const ((Immediate64 | Immediate) as imm) -> - equality_check (equate (of_desc l) value) - (of_const imm) - | _, _ -> equality_check (equate l1 l2) l1 - - let sub sub super = - let ok = Ok () in - let equality_check is_eq = if is_eq then ok - else Error (Violation.not_a_sublayout sub super) - in - match get sub, get super with - | _, Const Any -> ok - | Const c1, Const c2 when equal_const c1 c2 -> ok - | Const Immediate, Const Immediate64 -> ok - | Const (Immediate64 | Immediate), _ -> - equality_check (equate super value) - | _, _ -> equality_check (equate sub super) + match l1.layout, l2.layout with + (* only update the history when something interesting happens; e.g. + finding the intersection between a sublayout and its superlayout + is not interesting *) + | _, Any -> Ok l1 + | Any, _ -> Ok l2 + | (Immediate, Immediate) | (Immediate64, Immediate64) -> + Ok { l1 with history = combine_histories reason l1 l2 } + | Immediate, Immediate64 -> Ok l1 + | Immediate64, Immediate -> Ok l2 + | (Immediate | Immediate64), Sort s -> + if Sort.equate s Sort.value + then Ok l1 + else Error (Violation.of_ (No_intersection (l1, l2))) + | Sort s, (Immediate | Immediate64) -> + if Sort.equate s Sort.value + then Ok l2 + else Error (Violation.of_ (No_intersection (l1, l2))) + | Sort s1, Sort s2 -> + if Sort.equate s1 s2 + then Ok { l1 with history = combine_histories reason l1 l2 } + else Error (Violation.of_ (No_intersection (l1, l2))) + + (* this is hammered on; it must be fast! *) + let check_sub sub super : sub_result = + match sub.layout, super.layout with + (* don't use [get], because that allocates *) + | Any, Any -> Equal + | _, Any -> Sub + | Immediate, Immediate -> Equal + | Immediate64, Immediate64 -> Equal + | Immediate, Immediate64 -> Sub + | Immediate64, Immediate -> Not_sub + | (Immediate | Immediate64), Sort s -> + if Sort.equate s Sort.value then Sub else Not_sub + | Sort s1, Sort s2 -> + if Sort.equate s1 s2 then Equal else Not_sub + | Any, _ -> Not_sub + | Sort _, (Immediate | Immediate64) -> Not_sub + + let sub sub super = match check_sub sub super with + | Sub | Equal -> Ok () + | Not_sub -> Error (Violation.of_ (Not_a_sublayout (sub, super))) + + let sub_with_history sub super = match check_sub sub super with + | Sub | Equal -> + Ok { sub with history = combine_histories Sublayout sub super } + | Not_sub -> Error (Violation.of_ (Not_a_sublayout (sub, super))) + + let is_void_defaulting = function + | { layout = Sort s } -> Sort.is_void_defaulting s + | _ -> false + + let is_any = function + | { layout = Any } -> true + | _ -> false (*********************************) (* debugging *) @@ -617,23 +956,11 @@ end open Format let internal ppf : internal -> unit = function - | Any { missing_cmi_for } -> - fprintf ppf "Any { missing_cmi_for = %a }" - (Misc.Stdlib.Option.print Path.print) missing_cmi_for + | Any -> fprintf ppf "Any" | Sort s -> fprintf ppf "Sort %a" Sort.Debug_printers.t s | Immediate64 -> fprintf ppf "Immediate64" | Immediate -> fprintf ppf "Immediate" - let fixed_layout_reason ppf : fixed_layout_reason -> unit = function - | Let_binding -> fprintf ppf "Let_binding" - | Tuple_element -> fprintf ppf "Tuple_element" - | Probe -> fprintf ppf "Probe" - | Package_hack -> fprintf ppf "Package_hack" - | Object -> fprintf ppf "Object" - | Instance_variable -> fprintf ppf "Instance_variable" - | Object_field -> fprintf ppf "Object_field" - | Class_field -> fprintf ppf "Class_field" - let concrete_layout_reason ppf : concrete_layout_reason -> unit = function | Match -> fprintf ppf "Match" @@ -641,44 +968,144 @@ end fprintf ppf "Constructor_declaration %d" idx | Label_declaration lbl -> fprintf ppf "Label_declaration %a" Ident.print lbl - | Function_argument -> fprintf ppf "Function_argument" - | Function_result -> fprintf ppf "Function_result" + | Unannotated_type_parameter -> + fprintf ppf "Unannotated_type_parameter" + | Record_projection -> + fprintf ppf "Record_projection" + | Record_assignment -> + fprintf ppf "Record_assignment" + | Let_binding -> + fprintf ppf "Let_binding" + | Function_argument -> + fprintf ppf "Function_argument" + | Function_result -> + fprintf ppf "Function_result" + | Structure_item_expression -> + fprintf ppf "Structure_item_expression" + | V1_safety_check -> + fprintf ppf "V1_safety_check" - let annotation_location ppf : annotation_location -> unit = function + let annotation_context ppf : annotation_context -> unit = function | Type_declaration p -> fprintf ppf "Type_declaration %a" Path.print p | Type_parameter (p, var) -> fprintf ppf "Type_parameter (%a, %S)" Path.print p var - | With_constraint loc -> - fprintf ppf "With_constraint %a" Location.print_loc loc - | Newtype_declaration {loc; txt} -> - fprintf ppf "Newtype_declaration %s@@%a" txt Location.print_loc loc - - let reason ppf : reason -> unit = function - | Fixed_layout flr -> - fprintf ppf "Fixed_layout %a" fixed_layout_reason flr - | Concrete_layout clr -> - fprintf ppf "Concrete_layout %a" concrete_layout_reason clr - | Annotated aloc -> - fprintf ppf "Annotated %a" annotation_location aloc + | With_constraint s -> + fprintf ppf "With_constraint %S" s + | Newtype_declaration name -> + fprintf ppf "Newtype_declaration %s" name + + let any_creation_reason ppf : any_creation_reason -> unit = function + | Missing_cmi p -> fprintf ppf "Missing_cmi %a" Path.print p + | Wildcard -> fprintf ppf "Wildcard" + | Unification_var -> fprintf ppf "Unification_var" + | Initial_typedecl_env -> fprintf ppf "Initial_typedecl_env" + | Dummy_layout -> fprintf ppf "Dummy_layout" + | Type_expression_call -> fprintf ppf "Type_expression_call" + + let immediate_creation_reason ppf : immediate_creation_reason -> _ = + function + | Empty_record -> fprintf ppf "Empty_record" + | Enumeration -> fprintf ppf "Enumeration" + | Primitive id -> fprintf ppf "Primitive %s" (Ident.unique_name id) + | Immediate_polymorphic_variant -> + fprintf ppf "Immediate_polymorphic_variant" + | Gc_ignorable_check -> fprintf ppf "Gc_ignorable_check" + | Value_kind -> fprintf ppf "Value_kind" + + let immediate64_creation_reason ppf = function + | Local_mode_cross_check -> fprintf ppf "Local_mode_cross_check" + | Gc_ignorable_check -> fprintf ppf "Gc_ignorable_check" + | Separability_check -> fprintf ppf "Separability_check" + + let value_creation_reason ppf : value_creation_reason -> _ = function + | Class_let_binding -> fprintf ppf "Class_let_binding" + | Tuple_element -> fprintf ppf "Tuple_element" + | Probe -> fprintf ppf "Probe" + | Package_hack -> fprintf ppf "Package_hack" + | Object -> fprintf ppf "Object" + | Instance_variable -> fprintf ppf "Instance_variable" + | Object_field -> fprintf ppf "Object_field" + | Class_field -> fprintf ppf "Class_field" + | Boxed_record -> fprintf ppf "Boxed_record" + | Boxed_variant -> fprintf ppf "Boxed_variant" + | Extensible_variant -> fprintf ppf "Extensible_variant" + | Primitive id -> fprintf ppf "Primitive %s" (Ident.unique_name id) + | Type_argument -> fprintf ppf "Type_argument" + | Tuple -> fprintf ppf "Tuple" + | Row_variable -> fprintf ppf "Row_variable" + | Polymorphic_variant -> fprintf ppf "Polymorphic_variant" + | Arrow -> fprintf ppf "Arrow" + | Tfield -> fprintf ppf "Tfield" + | Tnil -> fprintf ppf "Tnil" + | First_class_module -> fprintf ppf "First_class_module" + | Separability_check -> fprintf ppf "Separability_check" + | Univar -> fprintf ppf "Univar" + | Polymorphic_variant_field -> fprintf ppf "Polymorphic_variant_field" + | Default_type_layout -> fprintf ppf "Default_type_layout" + | Float_record_field -> fprintf ppf "Float_record_field" + | Existential_type_variable -> fprintf ppf "Existential_type_variable" + | Array_element -> fprintf ppf "Array_element" + | Lazy_expression -> fprintf ppf "Lazy_expression" + | Class_argument -> fprintf ppf "Class_argument" + | Structure_element -> fprintf ppf "Structure_element" + | Debug_printer_argument -> fprintf ppf "Debug_printer_argument" + | V1_safety_check -> fprintf ppf "V1_safety_check" + | Unknown s -> fprintf ppf "Unknown %s" s + + let void_creation_reason ppf : void_creation_reason -> _ = function + | V1_safety_check -> fprintf ppf "V1_safety_check" + + let creation_reason ppf : creation_reason -> unit = function + | Annotated (ctx, loc) -> + fprintf ppf "Annotated (%a,%a)" + annotation_context ctx + Location.print_loc loc + | Any_creation any -> + fprintf ppf "Any_creation %a" any_creation_reason any + | Immediate_creation immediate -> + fprintf ppf "Immediate_creation %a" immediate_creation_reason immediate + | Immediate64_creation immediate64 -> + fprintf ppf "Immediate64_creation %a" immediate64_creation_reason immediate64 + | Value_creation value -> + fprintf ppf "Value_creation %a" value_creation_reason value + | Void_creation void -> + fprintf ppf "Void_creation %a" void_creation_reason void + | Concrete_creation concrete -> + fprintf ppf "Concrete_creation %a" concrete_layout_reason concrete + | Imported -> + fprintf ppf "Imported" + + let interact_reason ppf = function | Gadt_equation p -> - fprintf ppf "Gadt_equation %a" Path.print p - | Unified_with_tvar tv -> - fprintf ppf "Unified_with_tvar %a" - (Misc.Stdlib.Option.print pp_print_string) tv - | V1_safety_check -> - fprintf ppf "V1_safety_check" - | Dummy_reason_result_ignored -> - fprintf ppf "Dummy_reason_result_ignored" - - let reasons ppf (rs : reason list) : unit = - fprintf ppf "@[[ %a@]@,]" - (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf "@,; ") reason) rs - - let t ppf ({ layout; history } : t) : unit = + fprintf ppf "Gadt_equation %a" + Path.print p + | Tyvar_refinement_intersection -> + fprintf ppf "Tyvar_refinement_intersection" + | Sublayout -> + fprintf ppf "Sublayout" + + let rec history ppf = function + | Interact + { reason; lhs_layout; lhs_history; rhs_layout; rhs_history } -> + fprintf ppf "Interact {@[reason = %a;@ \ + lhs_layout = %a;@ \ + lhs_history = %a;@ \ + rhs_layout = %a;@ \ + rhs_history = %a}@]" + interact_reason reason + internal lhs_layout + history lhs_history + internal rhs_layout + history rhs_history + | Creation c -> + fprintf ppf "Creation (%a)" + creation_reason c + + let t ppf ({ layout; history=h } : t) : unit = fprintf ppf "@[{ layout = %a@,; history = %a }@]" internal layout - reasons history + history h end end diff --git a/ocaml/typing/layouts.mli b/ocaml/typing/layouts.mli index 5fda4cd1539..6ca1f98d43a 100644 --- a/ocaml/typing/layouts.mli +++ b/ocaml/typing/layouts.mli @@ -45,6 +45,15 @@ module Sort : sig equal, if possible *) val equate : t -> t -> bool + val format : Format.formatter -> t -> unit + + (** Defaults any variables to value; leaves other sorts alone *) + val default_to_value : t -> unit + + (** Checks whether this sort is [void], defaulting to [value] if a sort + variable is unfilled. *) + val is_void_defaulting : t -> bool + module Debug_printers : sig val t : Format.formatter -> t -> unit val var : Format.formatter -> var -> unit @@ -72,107 +81,120 @@ module Layout : sig [Any] and sublayouts of other sorts, such as [Immediate]. *) type t - (******************************) - (* constants *) - - (** Constant layouts are used both for user-written annotations and within - the type checker when we know a layout has no variables *) - type const = Asttypes.const_layout = - | Any - | Value - | Void - | Immediate64 - | Immediate - val string_of_const : const -> string - val equal_const : const -> const -> bool - - (** This layout is the top of the layout lattice. All types have layout [any]. - But we cannot compile run-time manipulations of values of types with - layout [any]. *) - val any : t - - (** This is a variant of the [any] layout used when we have to fill it in - because there's a missing .cmi file for the specified type. *) - val missing_cmi_any : Path.t -> t - - (** Value of types of this layout are not retained at all at runtime *) - val void : t - - (** This is the layout of normal ocaml values *) - val value : t - - (** Values of types of this layout are immediate on 64-bit platforms; on other - platforms, we know nothing other than that it's a value. *) - val immediate64 : t - - (** We know for sure that values of types of this layout are always immediate *) - val immediate : t - (******************************) (* errors *) - type fixed_layout_reason = - | Let_binding - | Tuple_element - | Probe - | Package_hack - | Object - | Instance_variable - | Object_field - | Class_field - type concrete_layout_reason = | Match | Constructor_declaration of int | Label_declaration of Ident.t + | Unannotated_type_parameter + | Record_projection + | Record_assignment + | Let_binding | Function_argument | Function_result + | Structure_item_expression + | V1_safety_check - type annotation_location = + type annotation_context = | Type_declaration of Path.t | Type_parameter of Path.t * string - | With_constraint of Location.t - | Newtype_declaration of string Location.loc + | With_constraint of string + | Newtype_declaration of string - type reason = - | Fixed_layout of fixed_layout_reason - | Concrete_layout of concrete_layout_reason - | Annotated of annotation_location - | Gadt_equation of Path.t - | Unified_with_tvar of string option - (* CR layouts v2: This really needs to carry a type, in case it - gets further unified. But that makes layouts recursive with - types, which will involve a painful restructuring. Still, RAE - thinks it's inevitable. *) + type value_creation_reason = + | Class_let_binding + | Tuple_element + | Probe + | Package_hack + | Object + | Instance_variable + | Object_field + | Class_field + | Boxed_record + | Boxed_variant + | Extensible_variant + | Primitive of Ident.t + | Type_argument (* CR layouts: Should this take a Path.t? *) + | Tuple + | Row_variable + | Polymorphic_variant + | Arrow + | Tfield + | Tnil + | First_class_module + | Separability_check + | Univar + | Polymorphic_variant_field + | Default_type_layout + | Float_record_field + | Existential_type_variable + | Array_element + | Lazy_expression + | Class_argument + | Structure_element + | Debug_printer_argument | V1_safety_check - | Dummy_reason_result_ignored + | Unknown of string (* CR layouts: get rid of these *) + + type immediate_creation_reason = + | Empty_record + | Enumeration + | Primitive of Ident.t + | Immediate_polymorphic_variant + | Gc_ignorable_check + | Value_kind + + type immediate64_creation_reason = + | Local_mode_cross_check + | Gc_ignorable_check + | Separability_check + + type void_creation_reason = + | V1_safety_check + + type any_creation_reason = + | Missing_cmi of Path.t + | Wildcard + | Unification_var + | Initial_typedecl_env + | Dummy_layout + (* This is used when the layout is about to get overwritten; + key example: when creating a fresh tyvar that is immediately + unified to correct levels *) + | Type_expression_call + + type creation_reason = + | Annotated of annotation_context * Location.t + | Value_creation of value_creation_reason + | Immediate_creation of immediate_creation_reason + | Immediate64_creation of immediate64_creation_reason + | Void_creation of void_creation_reason + | Any_creation of any_creation_reason + | Concrete_creation of concrete_layout_reason + | Imported + + type interact_reason = + | Gadt_equation of Path.t + | Tyvar_refinement_intersection + (* CR layouts: this needs to carry a type_expr, but that's loopy *) + | Sublayout module Violation : sig - type message = + type violation = | Not_a_sublayout of t * t | No_intersection of t * t - type violation = private - { message : message - ; missing_cmi : bool - (** Was this error caused by a missing .cmi file? This is redundant - with information stored in the [message], but is more easily - inspectable by external code. The error-printing code does not - inspect this value; it's only used for program logic. *) - } + type t - val not_a_sublayout : t -> t -> violation + val of_ : violation -> t - val no_intersection : t -> t -> violation + (** Mark a [t] as having arisen from a missing cmi *) + val record_missing_cmi : missing_cmi_for:Path.t -> t -> t - (* CR layouts: Is [missing_cmi] really the best thing? Maybe some functions - need to return success | error | missing_cmi. *) - - (** If we later discover that the left-hand layout was from a missing .cmi - file, and if that layout is [any], this function will update that layout - to report what type caused that (a la [missing_cmi_any]). *) - val add_missing_cmi_for_lhs : - missing_cmi_for:Path.t -> violation -> violation + (** Is this error from a missing cmi? *) + val is_missing_cmi : t -> bool (* CR layouts: The [offender] arguments below are always [Printtyp.type_expr], so we should either stash that in a ref (like with @@ -186,54 +208,87 @@ module Layout : sig ([offender], which you supply an arbitrary printer for). *) val report_with_offender : offender:(Format.formatter -> unit) -> - Format.formatter -> violation -> unit + Format.formatter -> t -> unit (** Like [report_with_offender], but additionally prints that the issue is that a representable layout was expected. *) val report_with_offender_sort : offender:(Format.formatter -> unit) -> - Format.formatter -> violation -> unit + Format.formatter -> t -> unit (** Simpler version of [report_with_offender] for when the thing that had an unexpected layout is available as a string. *) - val report_with_name : name:string -> Format.formatter -> violation -> unit - - (** Provides the [Printtyp.path] formatter back up the dependency chain to - this module. *) - val set_printtyp_path : (Format.formatter -> Path.t -> unit) -> unit + val report_with_name : name:string -> Format.formatter -> t -> unit end + (******************************) + (* constants *) + + (** Constant layouts are used both for user-written annotations and within + the type checker when we know a layout has no variables *) + type const = Asttypes.const_layout = + | Any + | Value + | Void + | Immediate64 + | Immediate + val string_of_const : const -> string + val equal_const : const -> const -> bool + + (** This layout is the top of the layout lattice. All types have layout [any]. + But we cannot compile run-time manipulations of values of types with layout + [any]. *) + val any : why:any_creation_reason -> t + + (** Value of types of this layout are not retained at all at runtime *) + val void : why:void_creation_reason -> t + + (** This is the layout of normal ocaml values *) + val value : why:value_creation_reason -> t + + (** Values of types of this layout are immediate on 64-bit platforms; on other + platforms, we know nothing other than that it's a value. *) + val immediate64 : why:immediate64_creation_reason -> t + + (** We know for sure that values of types of this layout are always immediate *) + val immediate : why:immediate_creation_reason -> t + (******************************) (* construction *) (** Create a fresh sort variable, packed into a layout. *) - val of_new_sort_var : unit -> t + val of_new_sort_var : why:concrete_layout_reason -> t - val of_sort : sort -> t - val of_const : const -> t + val of_sort : why:concrete_layout_reason -> sort -> t + val of_const : why:creation_reason -> const -> t (** Find a layout in attributes. Returns error if a disallowed layout is present, but always allows immediate attributes if ~legacy_immediate is true. See comment on [Builtin_attributes.layout]. *) val of_attributes : - legacy_immediate:bool -> reason:annotation_location -> Parsetree.attributes -> - (t option, Location.t * const) result + legacy_immediate:bool -> reason:annotation_context -> Parsetree.attributes -> + (t option, const Location.loc) result (** Find a layout in attributes, defaulting to ~default. Returns error if a disallowed layout is present, but always allows immediate if ~legacy_immediate is true. See comment on [Builtin_attributes.layout]. *) val of_attributes_default : - legacy_immediate:bool -> reason:annotation_location -> + legacy_immediate:bool -> reason:annotation_context -> default:t -> Parsetree.attributes -> - (t, Location.t * const) result + (t, const Location.loc) result (** Choose an appropriate layout for a boxed record type, given whether all of its fields are [void]. *) val for_boxed_record : all_void:bool -> t + (** Choose an appropriate layout for a boxed variant type, given whether + all of the fields of all of its constructors are [void]. *) + val for_boxed_variant : all_voids:bool -> t + (******************************) (* elimination and defaulting *) + (* The description of a layout, used as a return type from [get]. *) type desc = | Const of const | Var of Sort.var @@ -252,13 +307,11 @@ module Layout : sig (** [is_void t] is [Void = get_default_value t]. In particular, it will default the layout to value if needed to make this false. *) - val is_void : t -> bool + val is_void_defaulting : t -> bool (* CR layouts v5: When we have proper support for void, we'll want to change these three functions to default to void - it's the most efficient thing when we have a choice. *) - val of_desc : desc -> t - (** Returns the sort corresponding to the layout. Call only on representable layouts - raises on Any. *) val sort_of_layout : t -> sort @@ -268,10 +321,20 @@ module Layout : sig val to_string : t -> string val format : Format.formatter -> t -> unit + + (** Format the history of this layout: what interactions it has had and why + it is the layout that it is. Might be a no-op: see [display_histories] + in the implementation of the [Layout] module. + + The [intro] is something like "The layout of t is". *) val format_history : - pp_name:(Format.formatter -> 'a -> unit) -> name:'a -> + intro:(Format.formatter -> unit) -> Format.formatter -> t -> unit + (** Provides the [Printtyp.path] formatter back up the dependency chain to + this module. *) + val set_printtyp_path : (Format.formatter -> Path.t -> unit) -> unit + (******************************) (* relations *) @@ -286,33 +349,33 @@ module Layout : sig when there is no need for unification; e.g. [equal] on a var and [value] will crash. - This function ignores the [missing_cmi_for] medatadata for [any]s. - - CR layouts v2: At the moment, this is actually the same as [equate]! Fix. *) + CR layouts (v1.5): At the moment, this is actually the same as [equate]! *) val equal : t -> t -> bool (** Finds the intersection of two layouts, constraining sort variables to - create one if needed, or returns a [Violation.violation] if an - intersection does not exist. Can update the layouts. The returned - layout's history consists of the provided reason followed by the history - of the first layout argument. That is, due to histories, this function is - asymmetric; it should be thought of as modifying the first layout to be - the intersection of the two, not something that modifies the second - layout. *) + create one if needed, or returns a [Violation.t] if an intersection does + not exist. Can update the layouts. The returned layout's history + consists of the provided reason followed by the history of the first + layout argument. That is, due to histories, this function is asymmetric; + it should be thought of as modifying the first layout to be the + intersection of the two, not something that modifies the second layout. *) val intersection : - reason:reason -> t -> t -> (t, Violation.violation) Result.t + reason:interact_reason -> t -> t -> (t, Violation.t) Result.t - (** [sub t1 t2] returns [Ok t1] iff [t1] is a sublayout of - of [t2]. The current hierarchy is: + (** [sub t1 t2] returns [Ok ()] iff [t1] is a sublayout of + of [t2]. The current hierarchy is: Any > Sort Value > Immediate64 > Immediate Any > Sort Void Returns [Error _] if the coercion is not possible. *) - val sub : t -> t -> (unit, Violation.violation) result + val sub : t -> t -> (unit, Violation.t) result - (*********************************) - (* defaulting *) + (** Like [sub], but returns the sublayout with an updated history. *) + val sub_with_history : t -> t -> (t, Violation.t) result + + (** Checks to see whether a layout is any. Never does any mutation. *) + val is_any : t -> bool (*********************************) (* debugging *) diff --git a/ocaml/typing/oprint.ml b/ocaml/typing/oprint.ml index 1c4b136f0b9..a485bf0121a 100644 --- a/ocaml/typing/oprint.ml +++ b/ocaml/typing/oprint.ml @@ -284,9 +284,7 @@ let join_modes rm1 am2 = let print_out_layout ppf = function | Olay_const lay -> fprintf ppf "%s" (Layouts.Layout.string_of_const lay) - | Olay_var v -> fprintf ppf "%s" v - (* CR layouts: We need to either give these names somehow or not print - them at all *) + | Olay_var v -> fprintf ppf "%s" v let print_out_layout_option ppf = function | None -> () diff --git a/ocaml/typing/parmatch.ml b/ocaml/typing/parmatch.ml index 9e665425dba..d0cbdc74f4e 100644 --- a/ocaml/typing/parmatch.ml +++ b/ocaml/typing/parmatch.ml @@ -734,7 +734,9 @@ let close_variant env row = (orig_name, true) fields in if not closed || name != orig_name then begin let more' = - if static then Btype.newgenty Tnil else Btype.newgenvar Layout.value + if static + then Btype.newgenty Tnil + else Btype.newgenvar (Layout.value ~why:Row_variable) in (* this unification cannot fail *) Ctype.unify env more diff --git a/ocaml/typing/predef.ml b/ocaml/typing/predef.ml index 98a52ebb499..f5d196c0012 100644 --- a/ocaml/typing/predef.ml +++ b/ocaml/typing/predef.ml @@ -47,6 +47,9 @@ and ident_lazy_t = ident_create "lazy_t" and ident_string = ident_create "string" and ident_extension_constructor = ident_create "extension_constructor" and ident_floatarray = ident_create "floatarray" +and ident_unboxed_pair = ident_create "unboxed_pair" +and ident_unboxed_triple = ident_create "unboxed_triple" +and ident_real_void = ident_create "void" let path_int = Pident ident_int and path_char = Pident ident_char @@ -66,6 +69,9 @@ and path_lazy_t = Pident ident_lazy_t and path_string = Pident ident_string and path_extension_constructor = Pident ident_extension_constructor and path_floatarray = Pident ident_floatarray +and path_unboxed_pair = Pident ident_unboxed_pair +and path_unboxed_triple = Pident ident_unboxed_triple +and path_void = Pident ident_real_void let type_int = newgenty (Tconstr(path_int, [], ref Mnil)) and type_char = newgenty (Tconstr(path_char, [], ref Mnil)) @@ -142,7 +148,7 @@ and ident_some = ident_create "Some" let mk_add_type add_type ?manifest type_ident ?(kind=Type_abstract) - ?(layout=Layout.value) + ?(layout=Layout.value ~why:(Primitive type_ident)) env = let decl = {type_params = []; @@ -169,9 +175,9 @@ let common_initial_env add_type add_extension empty_env = let add_type = mk_add_type add_type and add_type1 type_ident ?(kind=fun _ -> Type_abstract) - ?(layout=Layout.value) + ?(layout=Layout.value ~why:(Primitive type_ident)) ~variance ~separability env = - let param = newgenvar Layout.value in + let param = newgenvar (Layout.value ~why:Type_argument) in let decl = {type_params = [param]; type_arity = 1; @@ -190,6 +196,55 @@ let common_initial_env add_type add_extension empty_env = } in add_type type_ident decl env + and add_type2 type_ident + ?(kind=fun _ -> Type_abstract) + ?(layout=Layout.value ~why:(Primitive type_ident)) + ~variance ~separability env = + let param0 = newgenvar (Layout.value ~why:Type_argument) in + let param1 = newgenvar (Layout.value ~why:Type_argument) in + let decl = + {type_params = [param0; param1]; + type_arity = 2; + type_kind = kind param0; + type_layout = layout; + type_loc = Location.none; + type_private = Asttypes.Public; + type_manifest = None; + type_variance = [variance; variance]; + type_separability = [separability; separability]; + type_is_newtype = false; + type_expansion_scope = lowest_level; + type_attributes = []; + type_unboxed_default = false; + type_uid = Uid.of_predef_id type_ident; + } + in + add_type type_ident decl env + and add_type3 type_ident + ?(kind=fun _ -> Type_abstract) + ?(layout=Layout.value ~why:(Primitive type_ident)) + ~variance ~separability env = + let param0 = newgenvar (Layout.value ~why:Type_argument) in + let param1 = newgenvar (Layout.value ~why:Type_argument) in + let param2 = newgenvar (Layout.value ~why:Type_argument) in + let decl = + {type_params = [param0; param1; param2]; + type_arity = 3; + type_kind = kind param0; + type_layout = layout; + type_loc = Location.none; + type_private = Asttypes.Public; + type_manifest = None; + type_variance = [variance; variance; variance]; + type_separability = [separability; separability; separability]; + type_is_newtype = false; + type_expansion_scope = lowest_level; + type_attributes = []; + type_unboxed_default = false; + type_uid = Uid.of_predef_id type_ident; + } + in + add_type type_ident decl env in let add_extension id args layouts = add_extension id @@ -219,15 +274,15 @@ let common_initial_env add_type add_extension empty_env = |> add_type ident_bool ~kind:(variant [cstr ident_false []; cstr ident_true []] [| [| |]; [| |] |]) - ~layout:Layout.immediate - |> add_type ident_char ~layout:Layout.immediate + ~layout:(Layout.immediate ~why:Enumeration) + |> add_type ident_char ~layout:(Layout.immediate ~why:(Primitive ident_char)) |> add_type ident_exn ~kind:Type_open - ~layout:Layout.value + ~layout:(Layout.value ~why:Extensible_variant) |> add_type ident_extension_constructor |> add_type ident_float |> add_type ident_floatarray - |> add_type ident_int ~layout:Layout.immediate + |> add_type ident_int ~layout:(Layout.immediate ~why:(Primitive ident_int)) |> add_type ident_int32 |> add_type ident_int64 |> add_type1 ident_lazy_t @@ -240,40 +295,50 @@ let common_initial_env add_type add_extension empty_env = variant [cstr ident_nil []; cstr ident_cons [tvar, Unrestricted; type_list tvar, Unrestricted]] - [| [| |]; [| Layout.value; - Layout.value |] |] ) - ~layout:Layout.value + [| [| |]; [| Layout.value ~why:Type_argument; + Layout.value ~why:Boxed_variant |] |] ) + ~layout:(Layout.value ~why:Boxed_variant) |> add_type ident_nativeint |> add_type1 ident_option ~variance:Variance.covariant ~separability:Separability.Ind ~kind:(fun tvar -> variant [cstr ident_none []; cstr ident_some [tvar, Unrestricted]] - [| [| |]; [| Layout.value |] |]) - ~layout:Layout.value + [| [| |]; [| Layout.value ~why:Type_argument |] |]) + ~layout:(Layout.value ~why:Boxed_variant) |> add_type ident_string |> add_type ident_unit ~kind:(variant [cstr ident_void []] [| [| |] |]) - ~layout:Layout.immediate + ~layout:(Layout.immediate ~why:Enumeration) + |> add_type2 ident_unboxed_pair + ~variance:Variance.covariant + ~separability:Separability.Ind + |> add_type3 ident_unboxed_triple + ~variance:Variance.covariant + ~separability:Separability.Ind + |> add_type ident_real_void (* Predefined exceptions - alphabetical order *) |> add_extension ident_assert_failure [newgenty (Ttuple[type_string; type_int; type_int])] - [| Layout.value |] + [| Layout.value ~why:Tuple |] |> add_extension ident_division_by_zero [] [||] |> add_extension ident_end_of_file [] [||] - |> add_extension ident_failure [type_string] [| Layout.value |] - |> add_extension ident_invalid_argument [type_string] [| Layout.value |] + |> add_extension ident_failure [type_string] + [| Layout.value ~why:(Primitive ident_string) |] + |> add_extension ident_invalid_argument [type_string] + [| Layout.value ~why:(Primitive ident_string) |] |> add_extension ident_match_failure [newgenty (Ttuple[type_string; type_int; type_int])] - [| Layout.value |] + [| Layout.value ~why:Tuple |] |> add_extension ident_not_found [] [||] |> add_extension ident_out_of_memory [] [||] |> add_extension ident_stack_overflow [] [||] |> add_extension ident_sys_blocked_io [] [||] - |> add_extension ident_sys_error [type_string] [| Layout.value |] + |> add_extension ident_sys_error [type_string] + [| Layout.value ~why:(Primitive ident_string) |] |> add_extension ident_undefined_recursive_module [newgenty (Ttuple[type_string; type_int; type_int])] - [| Layout.value |] + [| Layout.value ~why:Tuple |] let build_initial_env add_type add_exception empty_env = let common = common_initial_env add_type add_exception empty_env in diff --git a/ocaml/typing/predef.mli b/ocaml/typing/predef.mli index bb779b310af..8c451ea945d 100644 --- a/ocaml/typing/predef.mli +++ b/ocaml/typing/predef.mli @@ -54,6 +54,9 @@ val path_int64: Path.t val path_lazy_t: Path.t val path_extension_constructor: Path.t val path_floatarray: Path.t +val path_unboxed_pair: Path.t +val path_unboxed_triple: Path.t +val path_void: Path.t val path_match_failure: Path.t val path_invalid_argument: Path.t diff --git a/ocaml/typing/printtyp.ml b/ocaml/typing/printtyp.ml index 0fcb3a6a865..8573fc63499 100644 --- a/ocaml/typing/printtyp.ml +++ b/ocaml/typing/printtyp.ml @@ -467,7 +467,7 @@ let strings_of_paths namespace p = List.map (Format.asprintf "%a" !Oprint.out_ident) trees let () = Env.print_path := path -let () = Layouts.Layout.Violation.set_printtyp_path path +let () = Layouts.Layout.set_printtyp_path path (* Print a recursive annotation *) @@ -1487,7 +1487,7 @@ let rec tree_of_type_decl id decl = match Builtin_attributes.layout ~legacy_immediate:true decl.type_attributes with | Ok l -> l - | Error (_, l) -> Some l + | Error l_loc -> Some l_loc in let ty, priv, unboxed = match decl.type_kind with @@ -1519,7 +1519,7 @@ let rec tree_of_type_decl id decl = otype_params = args; otype_type = ty; otype_private = priv; - otype_layout = lay; + otype_layout = Option.map Location.get_txt lay; otype_unboxed = unboxed; otype_cstrs = constraints } @@ -1880,7 +1880,7 @@ let dummy = type_params = []; type_arity = 0; type_kind = Type_abstract; - type_layout = Layout.any; + type_layout = Layout.any ~why:Dummy_layout; type_private = Public; type_manifest = None; type_variance = []; @@ -2123,7 +2123,7 @@ let trees_of_type_expansion' | Tvar { layout; _ } | Tunivar { layout; _ } -> let olay = match Layouts.Layout.get layout with | Const clay -> Olay_const clay - | Var v -> Olay_var (Sort.var_name v) + | Var v -> Olay_var (Sort.var_name v) in Otyp_layout_annot (out, olay) | _ -> @@ -2244,7 +2244,8 @@ let hide_variant_name t = newty2 ~level:(get_level t) (Tvariant (create_row ~fields ~fixed ~closed ~name:None - ~more:(newvar2 (get_level more) Layout.value))) + ~more:(newvar2 (get_level more) + (Layout.value ~why:Row_variable)))) | _ -> t let prepare_expansion Errortrace.{ty; expanded} = @@ -2454,7 +2455,9 @@ let explanation (type variety) intro prev env (Layout.Violation.report_with_offender_sort ~offender:(fun ppf -> type_expr ppf t)) e) | Errortrace.Unequal_var_layouts (t1,l1,t2,l2) -> - let fmt_history t = Layout.format_history ~pp_name:type_expr ~name:t in + let fmt_history t = + Layout.format_history ~intro:(fun ppf -> type_expr ppf t) + in Some (dprintf "@ because their layouts are different.@[%a%a@]" (fmt_history t1) l1 (fmt_history t2) l2) diff --git a/ocaml/typing/printtyped.ml b/ocaml/typing/printtyped.ml index 97ac8abfca3..5a882d80b04 100644 --- a/ocaml/typing/printtyped.ml +++ b/ocaml/typing/printtyped.ml @@ -399,7 +399,7 @@ and expression i ppf x = | Texp_match (e, sort, l, _partial) -> line i ppf "Texp_match\n"; expression i ppf e; - line i ppf "%a\n" Layouts.Layout.format (Layouts.Layout.of_sort sort); + line i ppf "%a\n" Layouts.Sort.format sort; list i case ppf l; | Texp_try (e, l) -> line i ppf "Texp_try\n"; @@ -917,7 +917,7 @@ and structure_item i ppf x = | Tstr_eval (e, l, attrs) -> line i ppf "Tstr_eval\n"; attributes i ppf attrs; - Layouts.Layout.(line i ppf "%a\n" format (of_sort l)); + line i ppf "%a\n" Layouts.Sort.format l; expression i ppf e; | Tstr_value (rf, l) -> line i ppf "Tstr_value %a\n" fmt_rec_flag rf; diff --git a/ocaml/typing/subst.ml b/ocaml/typing/subst.ml index 28ced7d11d3..4bf9f1fd551 100644 --- a/ocaml/typing/subst.ml +++ b/ocaml/typing/subst.ml @@ -31,7 +31,11 @@ type t = { types: type_replacement Path.Map.t; modules: Path.t Path.Map.t; modtypes: module_type Path.Map.t; - for_saving: bool; + + (* given function should be applied to all layouts when saving; this commons + them up and truncates their histories *) + for_saving: (layout -> layout) option; + loc: Location.t option; mutable last_compose: (t * t) option (* Memoized composition *) } @@ -39,7 +43,7 @@ let identity = { types = Path.Map.empty; modules = Path.Map.empty; modtypes = Path.Map.empty; - for_saving = false; + for_saving = None; loc = None; last_compose = None; } @@ -61,7 +65,34 @@ let add_modtype_path p ty s = { s with modtypes = Path.Map.add p ty s.modtypes; last_compose = None } let add_modtype id ty s = add_modtype_path (Pident id) ty s -let for_saving s = { s with for_saving = true; last_compose = None } +let for_saving s = + (* CR layouts: it would be better to put all this stuff outside this + function, but it's in here because we really want to tailor the reason + to describe the module a symbol is imported from. But RAE's initial + attempt to do this based on filename caused spurious "inconsistent + assumption" errors that couldn't immediately be solved. Revisit + with a better approach. *) + let reason = Layout.Imported in + let any = Layout.of_const Any ~why:reason in + let void = Layout.of_const Void ~why:reason in + let value = Layout.of_const Value ~why:reason in + let immediate = Layout.of_const Immediate ~why:reason in + let immediate64 = Layout.of_const Immediate64 ~why:reason in + let share_layout lay = + match Layout.get lay with + | Const Any -> any + | Const Void -> void + | Const Value -> value + | Const Immediate -> immediate + | Const Immediate64 -> immediate64 + | Var _ -> lay + in + { s with for_saving = Some share_layout; last_compose = None } + +let apply_share_layout s lay = + match s.for_saving with + | Some share_layout -> share_layout lay + | None -> lay let change_locs s loc = { s with loc = Some loc; last_compose = None } @@ -69,7 +100,8 @@ let loc s x = match s.loc with | Some l -> l | None -> - if s.for_saving && not !Clflags.keep_locs then Location.none else x + if Option.is_some s.for_saving && not !Clflags.keep_locs + then Location.none else x let remove_loc = let open Ast_mapper in @@ -84,11 +116,11 @@ let is_not_doc = function let attrs s x = let x = - if s.for_saving && not !Clflags.keep_docs then + if Option.is_some s.for_saving && not !Clflags.keep_docs then List.filter is_not_doc x else x in - if s.for_saving && not !Clflags.keep_locs + if Option.is_some s.for_saving && not !Clflags.keep_locs then remove_loc.Ast_mapper.attributes remove_loc x else x @@ -150,51 +182,25 @@ let newpersty desc = create_expr desc ~level:generic_level ~scope:Btype.lowest_level ~id:!new_id -(* ensure that all occurrences of 'Tvar None' are physically shared when saving - artifacts *) -let tvar_none_any = Tvar { name = None; layout = Layout.any } -let tvar_none_imm = Tvar { name = None; layout = Layout.immediate } -let tvar_none_imm64 = Tvar { name = None; layout = Layout.immediate64 } -let tvar_none_val = Tvar { name = None; layout = Layout.value } -let tvar_none_void = Tvar { name = None; layout = Layout.void } - -let tunivar_none_any = Tunivar { name = None; layout = Layout.any } -let tunivar_none_imm = Tunivar { name = None; layout = Layout.immediate } -let tunivar_none_imm64 = Tunivar { name = None; layout = Layout.immediate64 } -let tunivar_none_val = Tunivar { name = None; layout = Layout.value } -let tunivar_none_void = Tunivar { name = None; layout = Layout.void} - -let norm = function - | (Tvar { name = None; layout }) as t -> begin - match Layout.get layout with - | Const Any -> tvar_none_any - | Const Immediate -> tvar_none_imm - | Const Immediate64 -> tvar_none_imm64 - | Const Value -> tvar_none_val - | Const Void -> tvar_none_void - | Var _ -> t - end - | (Tunivar { name = None; layout }) as t -> begin - match Layout.get layout with - | Const Any -> tunivar_none_any - | Const Immediate -> tunivar_none_imm - | Const Immediate64 -> tunivar_none_imm64 - | Const Value -> tunivar_none_val - | Const Void -> tunivar_none_void - | Var _ -> t - end - | d -> d +let norm s desc = match s with + | { for_saving = Some share_layout; _ } -> begin match desc with + | Tvar { name; layout } -> Tvar { name; layout = share_layout layout } + | Tunivar { name; layout } -> Tunivar { name; layout = share_layout layout } + | desc -> desc + end + | { for_saving = None; _ } -> assert false let ctype_apply_env_empty = ref (fun _ -> assert false) (* Similar to [Ctype.nondep_type_rec]. *) let rec typexp copy_scope s ty = + let for_saving = Option.is_some s.for_saving in let desc = get_desc ty in match desc with Tvar _ | Tunivar _ -> - if s.for_saving || get_id ty < 0 then + if for_saving || get_id ty < 0 then let ty' = - if s.for_saving then newpersty (norm desc) + if for_saving then newpersty (norm s desc) else newty2 ~level:(get_level ty) desc in For_copy.redirect_desc copy_scope ty (Tsubst (ty', None)); @@ -202,7 +208,7 @@ let rec typexp copy_scope s ty = else ty | Tsubst (ty, _) -> ty - | Tfield (m, k, _t1, _t2) when not s.for_saving && m = dummy_method + | Tfield (m, k, _t1, _t2) when not for_saving && m = dummy_method && field_kind_repr k <> Fabsent && get_level ty < generic_level -> (* do not copy the type of self when it is not generalized *) ty @@ -215,9 +221,9 @@ let rec typexp copy_scope s ty = let has_fixed_row = not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm in (* Make a stub *) - let layout = Layout.any in + let layout = Layout.any ~why:Dummy_layout in let ty' = - if s.for_saving then newpersty (Tvar {name = None; layout}) + if for_saving then newpersty (Tvar {name = None; layout}) else newgenstub ~scope:(get_scope ty) layout in For_copy.redirect_desc copy_scope ty (Tsubst (ty', None)); @@ -264,7 +270,7 @@ let rec typexp copy_scope s ty = Tlink ty2 | _ -> let dup = - s.for_saving || get_level more = generic_level || + for_saving || get_level more = generic_level || static_row row || is_Tconstr more in (* Various cases for the row variable *) let more' = @@ -272,7 +278,7 @@ let rec typexp copy_scope s ty = Tsubst (ty, None) -> ty | Tconstr _ | Tnil -> typexp copy_scope s more | Tunivar _ | Tvar _ -> - if s.for_saving then newpersty (norm mored) + if for_saving then newpersty mored else if dup && is_Tvar more then newgenty mored else more | _ -> assert false @@ -313,7 +319,7 @@ let label_declaration copy_scope s l = ld_id = l.ld_id; ld_mutable = l.ld_mutable; ld_global = l.ld_global; - ld_layout = l.ld_layout; + ld_layout = apply_share_layout s l.ld_layout; ld_type = typexp copy_scope s l.ld_type; ld_loc = loc s l.ld_loc; ld_attributes = attrs s l.ld_attributes; @@ -336,16 +342,49 @@ let constructor_declaration copy_scope s c = cd_uid = c.cd_uid; } +(* called only when for_saving is set *) +let constructor_tag share_layout = function + | Ordinary _ as tag -> tag + | Extension (path, lays) -> Extension (path, Array.map share_layout lays) + +(* called only when for_saving is set *) +let variant_representation share_layout = function + | Variant_unboxed -> Variant_unboxed + | Variant_boxed layss -> + Variant_boxed (Array.map (Array.map share_layout) layss) + | Variant_extensible -> Variant_extensible + +(* called only when for_saving is set *) +let record_representation share_layout = function + | Record_unboxed -> Record_unboxed + | Record_inlined (tag, variant_rep) -> + Record_inlined (constructor_tag share_layout tag, + variant_representation share_layout variant_rep) + | Record_boxed lays -> Record_boxed (Array.map share_layout lays) + | Record_float -> Record_float + let type_declaration' copy_scope s decl = + let share_layout, for_saving = match s.for_saving with + | Some share_layout -> share_layout, true + | None -> Fun.id, false + in { type_params = List.map (typexp copy_scope s) decl.type_params; type_arity = decl.type_arity; type_kind = begin match decl.type_kind with Type_abstract -> Type_abstract | Type_variant (cstrs, rep) -> + let rep = if for_saving + then variant_representation share_layout rep + else rep + in Type_variant (List.map (constructor_declaration copy_scope s) cstrs, rep) | Type_record(lbls, rep) -> + let rep = if for_saving + then record_representation share_layout rep + else rep + in Type_record (List.map (label_declaration copy_scope s) lbls, rep) | Type_open -> Type_open end; @@ -355,7 +394,7 @@ let type_declaration' copy_scope s decl = None -> None | Some ty -> Some(typexp copy_scope s ty) end; - type_layout = decl.type_layout; + type_layout = share_layout decl.type_layout; type_private = decl.type_private; type_variance = decl.type_variance; type_separability = decl.type_separability; @@ -433,12 +472,16 @@ let extension_constructor' copy_scope s ext = { ext_type_path = type_path s ext.ext_type_path; ext_type_params = List.map (typexp copy_scope s) ext.ext_type_params; ext_args = constructor_arguments copy_scope s ext.ext_args; - ext_arg_layouts = ext.ext_arg_layouts; + ext_arg_layouts = begin match s.for_saving with + | Some share_layouts -> Array.map share_layouts ext.ext_arg_layouts + | None -> ext.ext_arg_layouts + end; ext_constant = ext.ext_constant; ext_ret_type = Option.map (typexp copy_scope s) ext.ext_ret_type; ext_private = ext.ext_private; ext_attributes = attrs s ext.ext_attributes; - ext_loc = if s.for_saving then Location.none else ext.ext_loc; + ext_loc = if Option.is_some s.for_saving + then Location.none else ext.ext_loc; ext_uid = ext.ext_uid; } @@ -686,7 +729,9 @@ and compose s1 s2 = { types = merge_path_maps (type_replacement s2) s1.types s2.types; modules = merge_path_maps (module_path s2) s1.modules s2.modules; modtypes = merge_path_maps (modtype Keep s2) s1.modtypes s2.modtypes; - for_saving = s1.for_saving || s2.for_saving; + for_saving = Misc.Stdlib.Option.first_some + s1.for_saving + (fun () -> s2.for_saving); loc = keep_latest_loc s1.loc s2.loc; last_compose = None } diff --git a/ocaml/typing/typeclass.ml b/ocaml/typing/typeclass.ml index 7132a8111ce..d6f96ec8a13 100644 --- a/ocaml/typing/typeclass.ml +++ b/ocaml/typing/typeclass.ml @@ -109,7 +109,7 @@ type error = | Duplicate of string * string | Closing_self_type of class_signature | Polymorphic_class_parameter - | Non_value_binding of string * Layout.Violation.violation + | Non_value_binding of string * Layout.Violation.t exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -306,8 +306,8 @@ let rec class_type_field env sign self_scope ctf = let cty = transl_simple_type env ~closed:false Global sty in let ty = cty.ctyp_type in begin match - Ctype.constrain_type_layout ~reason:(Fixed_layout Instance_variable) - env ty Layout.value + Ctype.constrain_type_layout + env ty (Layout.value ~why:Instance_variable) with | Ok _ -> () | Error err -> raise (Error(loc, env, Non_value_binding(lab, err))) @@ -321,7 +321,9 @@ let rec class_type_field env sign self_scope ctf = let sty = Ast_helper.Typ.force_poly sty in match sty.ptyp_desc, priv with | Ptyp_poly ([],sty'), Public -> - let expected_ty = Ctype.newvar Layout.value in + let expected_ty = + Ctype.newvar (Layout.value ~why:Object_field) + in add_method loc env lab priv virt expected_ty sign; let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) env loc in delayed_meth_specs := @@ -668,8 +670,8 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = end; begin match - Ctype.constrain_type_layout ~reason:(Fixed_layout Class_field) - val_env ty Layout.value + Ctype.constrain_type_layout + val_env ty (Layout.value ~why:Class_field) with | Ok _ -> () | Error err -> raise (Error(label.loc, val_env, @@ -717,8 +719,9 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = end; begin match - Ctype.constrain_type_layout ~reason:(Fixed_layout Class_field) - val_env definition.exp_type Layout.value + Ctype.constrain_type_layout + val_env definition.exp_type + (Layout.value ~why:Class_field) with | Ok _ -> () | Error err -> raise (Error(label.loc, val_env, @@ -788,7 +791,7 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = in let ty = match sty with - | None -> Ctype.newvar Layout.value + | None -> Ctype.newvar (Layout.value ~why:Object_field) | Some sty -> let sty = Ast_helper.Typ.force_poly sty in let cty' = @@ -801,7 +804,9 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = try match get_desc ty with | Tvar _ -> - let ty' = Ctype.newvar Layout.value in + let ty' = + Ctype.newvar (Layout.value ~why:Object_field) + in Ctype.unify val_env (Ctype.newmono ty') ty; type_approx val_env sbody ty' | Tpoly (ty1, tl) -> @@ -1360,11 +1365,13 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = List.iter (fun (loc, mode, sort) -> Typecore.escape ~loc ~env:val_env ~reason:Other mode; - match Layout.sub (Layout.of_sort sort) Layout.value with - | Ok () -> () - | Error err -> - raise (Error(loc,met_env, - Non_value_binding (Ident.name id,err))) + if not (Sort.equate sort Sort.value) + then let viol = Layout.Violation.of_ (Not_a_sublayout( + Layout.of_sort ~why:Let_binding sort, + Layout.value ~why:Class_let_binding)) + in + raise (Error(loc, met_env, + Non_value_binding (Ident.name id, viol))) ) modes_and_sorts; let path = Pident id in @@ -1464,15 +1471,17 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = (* Approximate the type of the constructor to allow recursive use *) (* of optional parameters *) -let var_option = Predef.type_option (Btype.newgenvar Layout.value) +let var_option = + Predef.type_option (Btype.newgenvar (Layout.value ~why:Type_argument)) let rec approx_declaration cl = match cl.pcl_desc with Pcl_fun (l, _, _, cl) -> let arg = if Btype.is_optional l then Ctype.instance var_option - else Ctype.newvar Layout.value - (* CR layouts v2: use of value here may be relaxed *) + else Ctype.newvar (Layout.value ~why:Class_argument) + (* CR layouts: use of value here may be relaxed when we update + classes to work with layouts *) in let arg = Ctype.newmono arg in let arrow_desc = l, Alloc_mode.global, Alloc_mode.global in @@ -1482,36 +1491,37 @@ let rec approx_declaration cl = approx_declaration cl | Pcl_constraint (cl, _) -> approx_declaration cl - | _ -> Ctype.newvar Layout.value + | _ -> Ctype.newvar (Layout.value ~why:Object) let rec approx_description ct = match ct.pcty_desc with Pcty_arrow (l, _, ct) -> let arg = if Btype.is_optional l then Ctype.instance var_option - else Ctype.newvar Layout.value - (* CR layouts v2: use of value here may be relaxed *) + else Ctype.newvar (Layout.value ~why:Class_argument) + (* CR layouts: use of value here may be relaxed when we + relax layouts in classes *) in let arg = Ctype.newmono arg in let arrow_desc = l, Alloc_mode.global, Alloc_mode.global in Ctype.newty (Tarrow (arrow_desc, arg, approx_description ct, commu_ok)) - | _ -> Ctype.newvar Layout.value + | _ -> Ctype.newvar (Layout.value ~why:Object) (*******************************) let temp_abbrev loc env id arity uid = let params = ref [] in for _i = 1 to arity do - params := Ctype.newvar Layout.value :: !params + params := Ctype.newvar (Layout.value ~why:Type_argument) :: !params done; - let ty = Ctype.newobj (Ctype.newvar Layout.value) in + let ty = Ctype.newobj (Ctype.newvar (Layout.value ~why:Object)) in let env = Env.add_type ~check:true id {type_params = !params; type_arity = arity; type_kind = Type_abstract; - type_layout = Layout.value; + type_layout = Layout.value ~why:Object; type_private = Public; type_manifest = Some ty; type_variance = Variance.unknown_signature ~injective:false ~arity; @@ -1594,7 +1604,7 @@ let class_infos define_class kind let ci_params = let make_param (sty, v) = try - (transl_type_param env sty Layout.value, v) + (transl_type_param env sty (Layout.value ~why:Class_argument), v) with Already_bound -> raise(Error(sty.ptyp_loc, env, Repeated_parameter)) in @@ -1746,7 +1756,7 @@ let class_infos define_class kind type_params = obj_params; type_arity = arity; type_kind = Type_abstract; - type_layout = Layout.value; + type_layout = Layout.value ~why:Object; type_private = Public; type_manifest = Some obj_ty; type_variance = Variance.unknown_signature ~injective:false ~arity; @@ -1769,7 +1779,7 @@ let class_infos define_class kind type_params = cl_params; type_arity = arity; type_kind = Type_abstract; - type_layout = Layout.value; + type_layout = Layout.value ~why:Object; type_private = Public; type_manifest = Some cl_ty; type_variance = Variance.unknown_signature ~injective:false ~arity; diff --git a/ocaml/typing/typeclass.mli b/ocaml/typing/typeclass.mli index 355c5fdaf2a..4160099af85 100644 --- a/ocaml/typing/typeclass.mli +++ b/ocaml/typing/typeclass.mli @@ -125,7 +125,7 @@ type error = | Duplicate of string * string | Closing_self_type of class_signature | Polymorphic_class_parameter - | Non_value_binding of string * Layout.Violation.violation + | Non_value_binding of string * Layout.Violation.t exception Error of Location.t * Env.t * error exception Error_forward of Location.error diff --git a/ocaml/typing/typecore.ml b/ocaml/typing/typecore.ml index fba4e353cac..f63f0226e3c 100644 --- a/ocaml/typing/typecore.ml +++ b/ocaml/typing/typecore.ml @@ -121,7 +121,7 @@ type error = Datatype_kind.t * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list | Invalid_format of string | Not_an_object of type_expr * type_forcing_context option - | Not_a_value of Layout.Violation.violation * type_forcing_context option + | Not_a_value of Layout.Violation.t * type_forcing_context option | Undefined_method of type_expr * string * string list option | Undefined_self_method of string * string list | Virtual_class of Longident.t @@ -916,7 +916,7 @@ let enter_orpat_variables loc env p1_vs p2_vs = pv1 :: vars, alist else begin begin try - unify_var env (newvar Layout.any) t1; + unify_var env (newvar (Layout.any ~why:Dummy_layout)) t1; unify env t1 t2 with | Unify err -> @@ -996,7 +996,8 @@ and build_as_type_aux ~refine ~mode (env : Env.t ref) p = in let ty = let fields = [l, rf_present ty] in - newty (Tvariant (create_row ~fields ~more:(newvar Layout.value) + newty (Tvariant (create_row ~fields + ~more:(newvar (Layout.value ~why:Row_variable)) ~name:None ~fixed:None ~closed:false)) in ty, mode @@ -1007,7 +1008,7 @@ and build_as_type_aux ~refine ~mode (env : Env.t ref) p = [unify_pat]. *) (* CR layouts v2: This should be a sort variable and could be now (but think about when it gets defaulted.) *) - let ty = newvar Layout.any in + let ty = newvar (Layout.any ~why:Dummy_layout) in let ppl = List.map (fun (_, l, p) -> l.lbl_num, p) lpl in let do_label lbl = let _, ty_arg, ty_res = instance_label false lbl in @@ -1048,7 +1049,9 @@ and build_as_type_aux ~refine ~mode (env : Env.t ref) p = in let ty = newty (Tvariant (create_row ~fields ~fixed ~name - ~closed:false ~more:(newvar Layout.value))) + ~closed:false + ~more:(newvar + (Layout.value ~why:Row_variable)))) in ty, mode end @@ -1084,7 +1087,8 @@ let solve_Ppat_tuple (type a) ~refine ~alloc_mode loc env (args : a list) expect let ann = (* CR layouts v5: restriction to value here to be relaxed. *) List.map2 - (fun p mode -> (p, newgenvar Layout.value, simple_pat_mode mode)) + (fun p mode -> (p, newgenvar (Layout.value ~why:Tuple_element), + simple_pat_mode mode)) args arg_modes in let ty = newgenty (Ttuple (List.map snd3 ann)) in @@ -1100,7 +1104,8 @@ let solve_constructor_annotation tps env name_list sty ty_args ty_ex = (* CR layouts v1.5: I expect this needs to change when we allow layout annotations on explicitly quantified vars in gadt constructors. See: https://github.com/ocaml/ocaml/pull/9584/ *) - let decl = new_local_type ~loc:name.loc Layout.value in + let decl = new_local_type ~loc:name.loc + (Layout.value ~why:Existential_type_variable) in let (id, new_env) = Env.enter_type ~scope:expansion_scope name.txt decl !env in env := new_env; @@ -1230,14 +1235,14 @@ let solve_Ppat_array ~refine loc env mutability expected_ty = | Mutable -> Predef.type_array in (* CR layouts v4: in the future we'll have arrays of other layouts *) - let ty_elt = newgenvar Layout.value in + let ty_elt = newgenvar (Layout.value ~why:Array_element) in let expected_ty = generic_instance expected_ty in unify_pat_types ~refine loc env (type_some_array ty_elt) expected_ty; ty_elt let solve_Ppat_lazy ~refine loc env expected_ty = - let nv = newgenvar Layout.value in + let nv = newgenvar (Layout.value ~why:Lazy_expression) in unify_pat_types ~refine loc env (Predef.type_lazy_t nv) (generic_instance expected_ty); nv @@ -1260,23 +1265,32 @@ let solve_Ppat_constraint ~refine tps loc env mode sty expected_ty = let solve_Ppat_variant ~refine loc env tag no_arg expected_ty = (* CR layouts v5: relax the restriction to value here. *) - let arg_type = if no_arg then [] else [newgenvar Layout.value] in + let arg_type = + if no_arg + then [] + else [newgenvar (Layout.value ~why:Polymorphic_variant_field)] + in let fields = [tag, rf_either ~no_arg arg_type ~matched:true] in let make_row more = create_row ~fields ~closed:false ~more ~fixed:None ~name:None in - let row = make_row (newgenvar Layout.value) in + let row = make_row (newgenvar (Layout.value ~why:Row_variable)) in let expected_ty = generic_instance expected_ty in (* PR#7404: allow some_private_tag blindly, as it would not unify with the abstract row variable *) if tag <> Parmatch.some_private_tag then unify_pat_types ~refine loc env (newgenty(Tvariant row)) expected_ty; - (arg_type, make_row (newvar Layout.value), instance expected_ty) + (arg_type, make_row (newvar (Layout.value ~why:Row_variable)), + instance expected_ty) (* Building the or-pattern corresponding to a polymorphic variant type *) let build_or_pat env loc lid = let path, decl = Env.lookup_type ~loc:lid.loc lid.txt env in - let tyl = List.map (fun _ -> newvar Layout.value) decl.type_params in + (* CR layouts: the use of value here is wrong: + there could be other layouts in a polymorphic variant argument; + see Test 24 in tests/typing-layouts/basics_alpha.ml *) + let tyl = List.map (fun _ -> newvar (Layout.value ~why:Type_argument)) + decl.type_params in let row0 = let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in match get_desc ty with @@ -1304,9 +1318,12 @@ let build_or_pat env loc lid = let name = Some (path, tyl) in let make_row more = create_row ~fields ~more ~closed:false ~fixed:None ~name in - let ty = newty (Tvariant (make_row (newvar Layout.value))) in + let ty = newty (Tvariant (make_row + (newvar + (Layout.value ~why:Row_variable)))) + in let gloc = Location.ghostify loc in - let row' = ref (make_row (newvar Layout.value)) in + let row' = ref (make_row (newvar (Layout.value ~why:Row_variable))) in let pats = List.map (fun (l,p) -> @@ -2467,7 +2484,8 @@ and type_pat_aux | Record_type(p0, p, _, _) -> let ty = generic_instance expected_ty in Some (p0, p, is_principal expected_ty), ty - | Maybe_a_record_type -> None, newvar Layout.value + | Maybe_a_record_type -> + None, newvar (Layout.value ~why:Boxed_record) | Not_a_record_type -> let error = Wrong_expected_kind(Record, Pattern, expected_ty) in raise (Error (loc, !env, error)) @@ -2754,7 +2772,7 @@ let type_class_arg_pattern cl_num val_env met_env l spat = if !Clflags.principal then Ctype.begin_def (); let tps = create_type_pat_state Modules_rejected in (* CR layouts: will change when we relax layout restrictions in classes. *) - let nv = newvar Layout.value in + let nv = newvar (Layout.value ~why:Class_argument) in let alloc_mode = simple_pat_mode Value_mode.global in let pat = type_pat tps Value ~no_existentials:In_class_args ~alloc_mode @@ -2766,7 +2784,8 @@ let type_class_arg_pattern cl_num val_env met_env l spat = List.iter (fun f -> f()) tps.tps_pattern_force; (* CR layouts v5: value restriction here to be relaxed *) if is_optional l then - unify_pat (ref val_env) pat (type_option (newvar Layout.value)); + unify_pat (ref val_env) pat + (type_option (newvar (Layout.value ~why:Type_argument))); let pvs = tps.tps_pattern_variables in if !Clflags.principal then begin Ctype.end_def (); @@ -2810,7 +2829,7 @@ let type_self_pattern env spat = let open Ast_helper in let spat = Pat.mk(Ppat_alias (spat, mknoloc "selfpat-*")) in let tps = create_type_pat_state Modules_rejected in - let nv = newvar Layout.value in + let nv = newvar (Layout.value ~why:Object) in let alloc_mode = simple_pat_mode Value_mode.global in let pat = type_pat tps Value ~no_existentials:In_self_pattern ~alloc_mode @@ -3040,9 +3059,13 @@ let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs ret_tvar let ty_fun = expand_head env ty_fun in match get_desc ty_fun with | Tvar _ -> - let ty_arg_mono = newvar (Layout.of_new_sort_var ()) in + let ty_arg_mono = + newvar (Layout.of_new_sort_var ~why:Function_argument) + in let ty_arg = newmono ty_arg_mono in - let ty_res = newvar (Layout.of_new_sort_var ()) in + let ty_res = + newvar (Layout.of_new_sort_var ~why:Function_result) + in if ret_tvar && not (is_prim ~name:"%identity" funct) && not (is_prim ~name:"%obj_magic" funct) @@ -3465,7 +3488,7 @@ let rec approx_type env sty = match sty.ptyp_desc with | Ptyp_arrow (p, ({ ptyp_desc = Ptyp_poly _ } as arg_sty), sty) -> (* CR layouts v5: value requirement here to be relaxed *) - if is_optional p then newvar Layout.value + if is_optional p then newvar (Layout.value ~why:Type_argument) else begin let arg_mode = Typetexp.get_alloc_mode arg_sty in let arg_ty = @@ -3483,8 +3506,8 @@ let rec approx_type env sty = let arg_mode = Typetexp.get_alloc_mode arg_sty in let arg = if is_optional p - then type_option (newvar Layout.value) - else newvar (Layout.of_new_sort_var ()) + then type_option (newvar (Layout.value ~why:Type_argument)) + else newvar (Layout.of_new_sort_var ~why:Function_argument) in let ret = approx_type env sty in let marg = Alloc_mode.of_const arg_mode in @@ -3494,7 +3517,8 @@ let rec approx_type env sty = newty (Ttuple (List.map (approx_type env) args)) | Ptyp_constr (lid, ctl) -> let path, decl = Env.lookup_type ~use:false ~loc:lid.loc lid.txt env in - if List.length ctl <> decl.type_arity then newvar Layout.any + if List.length ctl <> decl.type_arity + then newvar (Layout.any ~why:Dummy_layout) else begin let tyl = List.map (approx_type env) ctl in newconstr path tyl @@ -3503,7 +3527,7 @@ let rec approx_type env sty = that could be matched on and have anys in them. But once we do, this should probably be sort variable. See Test21 in typing-layouts/basics.ml (which mentions approx_type) for why it can't be value. *) - | _ -> newvar Layout.any + | _ -> newvar (Layout.any ~why:Dummy_layout) and approx_type_jst _env _attrs : Jane_syntax.Core_type.t -> _ = function | _ -> . @@ -3587,7 +3611,9 @@ and type_approx_aux env sexp in_function ty_expected = | Pexp_match (_, {pc_rhs=e}::_) -> type_approx_aux env e None ty_expected | Pexp_try (e, _) -> type_approx_aux env e None ty_expected | Pexp_tuple l -> - let tys = List.map (fun _ -> newvar Layout.value) l in + let tys = List.map + (fun _ -> newvar (Layout.value ~why:Tuple_element)) l + in let ty = newty (Ttuple tys) in begin try unify env ty ty_expected with Unify err -> raise(Error(sexp.pexp_loc, env, Expr_type_clash (err, None, None))) @@ -3670,11 +3696,8 @@ let check_univars env kind exp ty_expected vars = 2) [polyfy] actually calls [expand_head] twice! why?! *) match get_desc (expand_head env var) with - | Tvar { name; layout = layout2; } -> begin - match - check_type_layout ~reason:(Unified_with_tvar name) - env uvar layout2 - with + | Tvar { layout = layout2; } -> begin + match check_type_layout env uvar layout2 with | Ok _ -> () | Error err -> error exp_ty ty_expected @@ -3924,7 +3947,8 @@ let check_absent_variant env = let fields = [s, rf_either ty_arg ~no_arg:(arg=None) ~matched:true] in let row' = create_row ~fields - ~more:(newvar Layout.value) ~closed:false ~fixed:None ~name:None + ~more:(newvar (Layout.value ~why:Row_variable)) + ~closed:false ~fixed:None ~name:None in (* Should fail *) unify_pat (ref env) {pat with pat_type = newty (Tvariant row')} @@ -4033,7 +4057,8 @@ let with_explanation explanation f = let rec type_exp ?recarg env expected_mode sexp = (* We now delegate everything to type_expect *) - type_expect ?recarg env expected_mode sexp (mk_expected (newvar Layout.any)) + type_expect ?recarg env expected_mode sexp + (mk_expected (newvar (Layout.any ~why:Dummy_layout))) (* Typing of an expression with an expected type. This provide better error messages, and allows controlled @@ -4208,7 +4233,9 @@ and type_expect_ let bound_exp = vb.vb_expr in let bound_exp_type = Ctype.instance bound_exp.exp_type in let loc = proper_exp_loc bound_exp in - let outer_var = newvar2 outer_level Layout.any in + let outer_var = + newvar2 outer_level (Layout.any ~why:Dummy_layout) + in (* Checking unification within an environment extended with the module bindings allows us to correctly accept more programs. This environment allows unification to identify more cases where @@ -4220,7 +4247,7 @@ and type_expect_ if may_contain_modules then begin end_def (); (* The "body" component of the scope escape check. *) - unify_exp new_env body (newvar Layout.any); + unify_exp new_env body (newvar (Layout.any ~why:Dummy_layout)); end; re { exp_desc = Texp_let(rec_flag, pat_exp_list, body); @@ -4367,16 +4394,17 @@ and type_expect_ if TypeSet.mem ty seen then false else match get_desc ty with Tarrow (_l, ty_arg, ty_fun, _com) -> - (try unify_var env (newvar Layout.any) ty_arg + (try unify_var env + (newvar (Layout.any ~why:Dummy_layout)) ty_arg with Unify _ -> assert false); ret_tvar (TypeSet.add ty seen) ty_fun | Tvar _ -> - let v = newvar Layout.any in + let v = newvar (Layout.any ~why:Dummy_layout) in let rt = get_level ty > get_level v in unify_var env v ty; rt | _ -> - let v = newvar Layout.any in + let v = newvar (Layout.any ~why:Dummy_layout) in unify_var env v ty; false in @@ -4443,7 +4471,7 @@ and type_expect_ let sort = Sort.new_var () in let arg = type_expect env arg_expected_mode sarg - (mk_expected (newvar (Layout.of_sort sort))) + (mk_expected (newvar (Layout.of_sort ~why:Match sort))) in end_def (); if maybe_expansive arg then lower_contravariant env arg.exp_type; @@ -4477,7 +4505,10 @@ and type_expect_ assert (arity >= 2); let alloc_mode = register_allocation expected_mode in (* CR layouts v5: non-values in tuples *) - let subtypes = List.map (fun _ -> newgenvar Layout.value) sexpl in + let subtypes = + List.map (fun _ -> newgenvar (Layout.value ~why:Tuple_element)) + sexpl + in let to_unify = newgenty (Ttuple subtypes) in with_explanation (fun () -> unify_exp_types loc env to_unify (generic_instance ty_expected)); @@ -4545,7 +4576,7 @@ and type_expect_ let row = create_row ~fields: [l, rf_present arg_type] - ~more: (newvar Layout.value) + ~more: (newvar (Layout.value ~why:Row_variable)) ~closed: false ~fixed: None ~name: None @@ -4595,7 +4626,8 @@ and type_expect_ raise (Error (exp.exp_loc, env, error)) in match expected_opath, opt_exp_opath with - | None, None -> newvar (Layout.of_new_sort_var ()), None + | None, None -> + newvar (Layout.of_new_sort_var ~why:Record_projection), None | Some _, None -> ty_expected, expected_opath | Some(_, _, true), Some _ -> ty_expected, expected_opath | (None | Some (_, _, false)), Some (_, p', _) -> @@ -4755,7 +4787,8 @@ and type_expect_ let (record, rmode, label, expected_type) = type_label_access env srecord Env.Mutation lid in let ty_record = - if expected_type = None then newvar (Layout.of_new_sort_var ()) + if expected_type = None + then newvar (Layout.of_new_sort_var ~why:Record_assignment) else record.exp_type in let (label_loc, label, newval) = @@ -4911,7 +4944,7 @@ and type_expect_ begin_def (); let arg = type_exp env expected_mode sarg in end_def (); - let tv = newvar Layout.any in + let tv = newvar (Layout.any ~why:Dummy_layout) in let gen = generalizable (get_level tv) arg.exp_type in unify_var env tv arg.exp_type; begin match arg.exp_desc, !self_coercion, get_desc ty' with @@ -5005,7 +5038,7 @@ and type_expect_ | id -> id, Btype.method_type met sign | exception Not_found -> let id = Ident.create_local met in - let ty = newvar Layout.value in + let ty = newvar (Layout.value ~why:Object_field) in meths_ref := Meths.add met id !meths_ref; add_method env met Private Virtual ty sign; Location.prerr_warning loc @@ -5076,7 +5109,7 @@ and type_expect_ (Warnings.Not_principal "this use of a polymorphic method"); snd (instance_poly false tl ty) | Tvar _ -> - let ty' = newvar Layout.value in + let ty' = newvar (Layout.value ~why:Object_field) in unify env (instance typ) (newty(Tpoly(ty',[]))); (* if not !Clflags.nolabels then Location.prerr_warning loc (Warnings.Unknown_method met); *) @@ -5171,7 +5204,7 @@ and type_expect_ assert false end | Pexp_letmodule(name, smodl, sbody) -> - let ty = newvar Layout.any in + let ty = newvar (Layout.any ~why:Dummy_layout) in (* remember original level *) begin_def (); let modl, pres, id, new_env = Typetexp.TyVarEnv.with_local_scope begin fun () -> @@ -5246,7 +5279,7 @@ and type_expect_ exp_env = env; } | Pexp_lazy e -> - let ty = newgenvar Layout.value in + let ty = newgenvar (Layout.value ~why:Lazy_expression) in let to_unify = Predef.type_lazy_t ty in with_explanation (fun () -> unify_exp_types loc env to_unify (generic_instance ty_expected)); @@ -5311,15 +5344,15 @@ and type_expect_ in re { exp with exp_extra = (Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra } - | Pexp_newtype({txt=name} as lname, sbody) -> + | Pexp_newtype({txt=name}, sbody) -> let layout = match Layout.of_attributes_default ~legacy_immediate:false - ~reason:(Newtype_declaration lname) - ~default:Layout.value sexp.pexp_attributes + ~reason:(Newtype_declaration name) + ~default:(Layout.value ~why:Univar) sexp.pexp_attributes with | Ok l -> l - | Error (loc, layout) -> - raise (Error (loc, env, Layout_not_enabled layout)) + | Error { loc; txt } -> + raise (Error (loc, env, Layout_not_enabled txt)) in let ty = if Typetexp.valid_tyvar_name name then @@ -5383,7 +5416,7 @@ and type_expect_ exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_open (od, e) -> - let tv = newvar Layout.any in + let tv = newvar (Layout.any ~why:Dummy_layout) in let (od, _, newenv) = !type_open_decl env od in let exp = type_expect newenv expected_mode e ty_expected_explained in (* Force the return type to be well-formed in the original @@ -5403,7 +5436,7 @@ and type_expect_ | [] -> spat_acc, ty_acc | { pbop_pat = spat; _} :: rest -> (* CR layouts v5: eliminate value requirement *) - let ty = newvar Layout.value in + let ty = newvar (Layout.value ~why:Tuple_element) in let loc = Location.ghostify slet.pbop_op.loc in let spat_acc = Ast_helper.Pat.tuple ~loc [spat_acc; spat] in let ty_acc = newty (Ttuple [ty_acc; ty]) in @@ -5414,24 +5447,22 @@ and type_expect_ let op_path, op_desc = type_binding_op_ident env slet.pbop_op in let op_type = instance op_desc.val_type in let spat_params, ty_params = - (* The use of a sort var here instead of a value is a little suspect, - because this can be the component of a tuple if there are several - [and] operators. In practice, all will be OK, though, because this - type will get unified with a tuple type (in the [type_cases] below) - and the sort var will get set to [value]. However, we still use a - sort var here to allow for a non-[value] type when there are no - [and]s. *) - (* CR layouts v5: Remove above comment when we support tuples of - non-[value] types. *) - loop slet.pbop_pat (newvar (Layout.of_new_sort_var ())) sands - in - let ty_func_result = newvar (Layout.of_new_sort_var ()) in + let initial_layout = match sands with + | [] -> Layout.of_new_sort_var ~why:Function_argument + (* CR layouts v5: eliminate value requirement for tuple elements *) + | _ -> Layout.value ~why:Tuple_element + in + loop slet.pbop_pat (newvar initial_layout) sands + in + let ty_func_result = + newvar (Layout.of_new_sort_var ~why:Function_result) + in let arrow_desc = Nolabel, Alloc_mode.global, Alloc_mode.global in let ty_func = newty (Tarrow(arrow_desc, newmono ty_params, ty_func_result, commu_ok)) in - let ty_result = newvar (Layout.of_new_sort_var ()) in - let ty_andops = newvar (Layout.of_new_sort_var ()) in + let ty_result = newvar (Layout.of_new_sort_var ~why:Function_result) in + let ty_andops = newvar (Layout.of_new_sort_var ~why:Function_argument) in let ty_op = newty (Tarrow(arrow_desc, newmono ty_andops, newty (Tarrow(arrow_desc, newmono ty_func, @@ -5695,7 +5726,7 @@ and type_function ?in_function loc attrs env (expected_mode : expected_mode) let snap = Btype.snapshot () in let really_poly = try - unify env (newmono (newvar Layout.any)) ty_arg; + unify env (newmono (newvar (Layout.any ~why:Dummy_layout))) ty_arg; false with Unify _ -> true in @@ -6334,7 +6365,8 @@ and type_apply_arg env ~app_loc ~funct ~index ~position ~partial_app (lbl, arg) in if is_optional lbl then (* CR layouts v5: relax value requirement *) - unify_exp env arg (type_option(newvar Layout.value)); + unify_exp env arg + (type_option(newvar (Layout.value ~why:Type_argument))); (lbl, Arg (arg, expected_mode.mode)) | Arg (Known_arg { sarg; ty_arg; ty_arg0; mode_arg; wrapped_in_some }) -> @@ -6360,7 +6392,8 @@ and type_apply_arg env ~app_loc ~funct ~index ~position ~partial_app (lbl, arg) let snap = Btype.snapshot () in let really_poly = try - unify env (newmono (newvar Layout.any)) ty_arg; + unify env (newmono (newvar (Layout.any ~why:Dummy_layout))) + ty_arg; false with Unify _ -> true in @@ -6586,7 +6619,8 @@ and type_statement ?explanation ?(position=RNontail) env sexp = let exp = type_exp env (mode_local_with_position position) sexp in end_def(); let ty = expand_head env exp.exp_type - and tv = newvar Layout.any in + and tv = newvar (Layout.any ~why:Dummy_layout) + in if is_Tvar ty && get_level ty > get_level tv then Location.prerr_warning (final_subexpression exp).exp_loc @@ -6692,7 +6726,7 @@ and type_cases else ty_res, (fun env -> env) in (* Unify all cases (delayed to keep it order-free) *) - let ty_arg' = newvar Layout.any in + let ty_arg' = newvar (Layout.any ~why:Dummy_layout) in let unify_pats ty = List.iter (fun { typed_pat = pat; pat_type_for_unif = pat_ty; _ } -> unify_pat_types pat.pat_loc (ref env) pat_ty ty @@ -6711,7 +6745,7 @@ and type_cases if take_partial_instance <> None then unify_pats (instance ty_arg); List.iter (fun { pat_vars; _ } -> iter_pattern_variables_type - (fun t -> unify_var env (newvar Layout.any) t) + (fun t -> unify_var env (newvar (Layout.any ~why:Dummy_layout)) t) pat_vars ) half_typed_cases; end_def (); @@ -6812,7 +6846,8 @@ and type_cases if create_inner_level then begin end_def (); (* Ensure that existential types do not escape *) - unify_exp_types loc env (instance ty_res) (newvar Layout.any); + unify_exp_types loc env (instance ty_res) + (newvar (Layout.any ~why:Dummy_layout)); end; cases, partial @@ -6902,7 +6937,9 @@ and type_let spat_sexp_list in let is_recursive = (rec_flag = Recursive) in let sorts = List.map (fun _ -> Sort.new_var ()) spatl in - let nvs = List.map (fun s -> newvar (Layout.of_sort s)) sorts in + let nvs = + List.map (fun s -> newvar (Layout.of_sort ~why:Let_binding s)) sorts + in if is_recursive then begin_def (); let (pat_list, new_env, force, pvs, mvs) = type_pattern_list Value existential_context env spatl nvs allow_modules @@ -7161,9 +7198,9 @@ and type_andops env sarg sands expected_ty = if !Clflags.principal then begin_def (); let op_path, op_desc = type_binding_op_ident env sop in let op_type = op_desc.val_type in - let ty_arg = newvar (Layout.of_new_sort_var ()) in - let ty_rest = newvar (Layout.of_new_sort_var ()) in - let ty_result = newvar (Layout.of_new_sort_var ()) in + let ty_arg = newvar (Layout.of_new_sort_var ~why:Function_argument) in + let ty_rest = newvar (Layout.of_new_sort_var ~why:Function_argument) in + let ty_result = newvar (Layout.of_new_sort_var ~why:Function_result) in let arrow_desc = (Nolabel,Alloc_mode.global,Alloc_mode.global) in let ty_rest_fun = newty (Tarrow(arrow_desc, newmono ty_arg, ty_result, commu_ok)) @@ -7218,7 +7255,7 @@ and type_generic_array = let alloc_mode = register_allocation expected_mode in (* CR layouts v4: non-values in arrays *) - let ty = newgenvar Layout.value in + let ty = newgenvar (Layout.value ~why:Array_element) in let to_unify = type_ ty in with_explanation explanation (fun () -> unify_exp_types loc env to_unify (generic_instance ty_expected)); @@ -7334,13 +7371,15 @@ and type_comprehension_expr comprehension. - [{body = sbody; clauses}]: The actual comprehension to be translated. *) - let comprehension_type, container_type, make_texp, {body = sbody; clauses} = + let comprehension_type, container_type, make_texp, + {body = sbody; clauses}, reason = match cexpr with | Cexp_list_comprehension comp -> List_comprehension, Predef.type_list, (fun tcomp -> Texp_list_comprehension tcomp), - comp + comp, + Layout.Type_argument | Cexp_array_comprehension (amut, comp) -> let container_type = match amut with | Mutable -> Predef.type_array @@ -7349,10 +7388,11 @@ and type_comprehension_expr Array_comprehension amut, container_type, (fun tcomp -> Texp_array_comprehension (amut, tcomp)), - comp + comp, + Layout.Array_element in if !Clflags.principal then begin_def (); - let element_ty = newvar Layout.value in + let element_ty = newvar (Layout.value ~why:reason) in unify_exp_types loc env @@ -7457,7 +7497,7 @@ and type_comprehension_iterator in Texp_comp_range { ident; pattern; start; stop; direction } | In seq -> - let item_ty = newvar Layout.any in + let item_ty = newvar (Layout.any ~why:Dummy_layout) in let seq_ty = container_type item_ty in let sequence = (* To understand why we can currently only iterate over [mode_global] @@ -7541,12 +7581,13 @@ let type_expression env layout sexp = {exp with exp_type = desc.val_type} | _ -> exp -let type_representable_expression env sexp = +let type_representable_expression ~why env sexp = let sort = Sort.new_var () in - let exp = type_expression env (Layout.of_sort sort) sexp in + let exp = type_expression env (Layout.of_sort ~why sort) sexp in exp, sort -let type_expression env sexp = type_expression env Layout.any sexp +let type_expression env sexp = + type_expression env (Layout.any ~why:Type_expression_call) sexp (* Error report *) diff --git a/ocaml/typing/typecore.mli b/ocaml/typing/typecore.mli index 859670ed57c..26105952cc7 100644 --- a/ocaml/typing/typecore.mli +++ b/ocaml/typing/typecore.mli @@ -122,6 +122,7 @@ val type_let: val type_expression: Env.t -> Parsetree.expression -> Typedtree.expression val type_representable_expression: + why:Layouts.Layout.concrete_layout_reason -> Env.t -> Parsetree.expression -> Typedtree.expression * sort val type_class_arg_pattern: string -> Env.t -> Env.t -> arg_label -> Parsetree.pattern -> @@ -196,7 +197,7 @@ type error = Datatype_kind.t * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list | Invalid_format of string | Not_an_object of type_expr * type_forcing_context option - | Not_a_value of Layout.Violation.violation * type_forcing_context option + | Not_a_value of Layout.Violation.t * type_forcing_context option | Undefined_method of type_expr * string * string list option | Undefined_self_method of string * string list | Virtual_class of Longident.t diff --git a/ocaml/typing/typedecl.ml b/ocaml/typing/typedecl.ml index 06ce5c4a8d0..62e10e10fd5 100644 --- a/ocaml/typing/typedecl.ml +++ b/ocaml/typing/typedecl.ml @@ -63,12 +63,12 @@ type error = | Multiple_native_repr_attributes | Cannot_unbox_or_untag_type of native_repr_kind | Deep_unbox_or_untag_attribute of native_repr_kind - | Layout_coherence_check of type_expr * Layout.Violation.violation - | Layout_update_check of Path.t * Layout.Violation.violation + | Layout_coherence_check of type_expr * Layout.Violation.t + | Layout_update_check of Path.t * Layout.Violation.t | Layout_sort of { lloc : layout_sort_loc ; typ : type_expr - ; err : Layout.Violation.violation + ; err : Layout.Violation.t } | Layout_empty_record | Separability of Typedecl_separability.error @@ -87,12 +87,12 @@ exception Error of Location.t * error let layout_of_attributes ~legacy_immediate ~reason attrs = match Layout.of_attributes ~legacy_immediate ~reason attrs with | Ok l -> l - | Error (loc, c) -> raise (Error (loc, Layout_not_enabled c)) + | Error { loc; txt } -> raise (Error (loc, Layout_not_enabled txt)) let layout_of_attributes_default ~legacy_immediate ~reason ~default attrs = match Layout.of_attributes_default ~legacy_immediate ~reason ~default attrs with | Ok l -> l - | Error (loc, c) -> raise (Error (loc, Layout_not_enabled c)) + | Error { loc; txt } -> raise (Error (loc, Layout_not_enabled txt)) let get_unboxed_from_attributes sdecl = let unboxed = Builtin_attributes.has_unboxed sdecl.ptype_attributes in @@ -133,6 +133,7 @@ let enter_type rec_flag env sdecl (id, uid) = in if not needed then env else let arity = List.length sdecl.ptype_params in + let path = Path.Pident id in (* There is some trickiness going on here with the layout. It expands on an old trick used in the manifest of [decl] below. @@ -191,8 +192,8 @@ let enter_type rec_flag env sdecl (id, uid) = (* We set ~legacy_immediate to true because we're looking at a declaration that was already allowed to be [@@immediate] *) layout_of_attributes_default - ~legacy_immediate:true ~reason:(Type_declaration (Pident id)) - ~default:Layout.any + ~legacy_immediate:true ~reason:(Type_declaration path) + ~default:(Layout.any ~why:Initial_typedecl_env) sdecl.ptype_attributes in let decl = @@ -226,8 +227,8 @@ let enter_type rec_flag env sdecl (id, uid) = (fun (param, _) -> let layout = layout_of_attributes_default ~legacy_immediate:false - ~reason:(Type_parameter (Pident id, parameter_name param)) - ~default:Layout.value + ~reason:(Type_parameter (path, parameter_name param)) + ~default:(Layout.value ~why:Type_argument) param.ptyp_attributes in Btype.newgenvar layout) @@ -340,7 +341,7 @@ let set_private_row env loc p decl = (* [make_params] creates sort variables - these can be defaulted away (as in transl_type_decl) or unified with existing sort-variable-free types (as in transl_with_constraint). *) -let make_params env id params = +let make_params env path params = (* Our choice for now is that if you want a parameter of layout any, you have to ask for it with an annotation. Some restriction here seems necessary for backwards compatibility (e.g., we wouldn't want [type 'a id = 'a] to @@ -349,8 +350,9 @@ let make_params env id params = try let layout = layout_of_attributes_default ~legacy_immediate:false - ~reason:(Type_parameter (id, parameter_name sty)) - ~default:(Layout.of_new_sort_var ()) sty.ptyp_attributes + ~reason:(Type_parameter (path, parameter_name sty)) + ~default:(Layout.of_new_sort_var ~why:Unannotated_type_parameter) + sty.ptyp_attributes in (transl_type_param env sty layout, v) with Already_bound -> @@ -407,7 +409,8 @@ let transl_labels env univars closed lbls = {Types.ld_id = ld.ld_id; ld_mutable = ld.ld_mutable; ld_global = ld.ld_global; - ld_layout = Layout.any; (* Updated by [update_label_layouts] *) + ld_layout = Layout.any ~why:Dummy_layout; + (* Updated by [update_label_layouts] *) ld_type = ty; ld_loc = ld.ld_loc; ld_attributes = ld.ld_attributes; @@ -488,7 +491,10 @@ let make_constructor env loc type_path type_params svars sargs sret_type = Btype.iter_type_expr_cstr_args Ctype.generalize args; Ctype.generalize ret_type; let _vars = TyVarEnv.instance_poly_univars env loc univars in - let set_level t = Ctype.unify_var env (Ctype.newvar Layout.any) t in + let set_level t = + Ctype.unify_var env + (Ctype.newvar (Layout.any ~why:Dummy_layout)) t + in Btype.iter_type_expr_cstr_args set_level args; set_level ret_type; end; @@ -646,6 +652,7 @@ let transl_declaration env sdecl (id, uid) = let cty = transl_simple_type env ~closed:no_row Global sty in Some cty, Some cty.ctyp_type in + let any = Layout.any ~why:Initial_typedecl_env in (* layout_default is the layout to use for now as the type_layout when there is no annotation and no manifest. See Note [Default layouts in transl_declaration]. @@ -653,7 +660,7 @@ let transl_declaration env sdecl (id, uid) = let (tkind, kind, layout_default) = match sdecl.ptype_kind with | Ptype_abstract -> - Ttype_abstract, Type_abstract, Layout.value + Ttype_abstract, Type_abstract, Layout.value ~why:Default_type_layout | Ptype_variant scstrs -> if List.exists (fun cstr -> cstr.pcd_res <> None) scstrs then begin match cstrs with @@ -704,7 +711,7 @@ let transl_declaration env sdecl (id, uid) = let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in let rep, layout = if unbox then - Variant_unboxed, Layout.any + Variant_unboxed, any else (* We mark all arg layouts "any" here. They are updated later, after the circular type checks make it safe to check layouts. *) @@ -712,26 +719,27 @@ let transl_declaration env sdecl (id, uid) = Array.map (fun cstr -> match Types.(cstr.cd_args) with - | Cstr_tuple args -> Array.make (List.length args) Layout.any - | Cstr_record _ -> [| Layout.any |]) + | Cstr_tuple args -> + Array.make (List.length args) any + | Cstr_record _ -> [| any |]) (Array.of_list cstrs) ), - Layout.value + Layout.value ~why:Boxed_variant in Ttype_variant tcstrs, Type_variant (cstrs, rep), layout | Ptype_record lbls -> let lbls, lbls' = transl_labels env None true lbls in let rep, layout = if unbox then - Record_unboxed, Layout.any + Record_unboxed, any else (if List.for_all (fun l -> is_float env l.Types.ld_type) lbls' then Record_float - else Record_boxed (Array.make (List.length lbls) Layout.any)), - Layout.value + else Record_boxed (Array.make (List.length lbls) any)), + Layout.value ~why:Boxed_record in Ttype_record lbls, Type_record(lbls', rep), layout | Ptype_open -> - Ttype_open, Type_open, Layout.value + Ttype_open, Type_open, Layout.value ~why:Extensible_variant in let layout = (* - If there's an annotation, we use that. It's checked against @@ -984,8 +992,8 @@ let check_coherence env loc dpath decl = else Ctype.type_layout env ty in - begin match Layout.sub layout' decl.type_layout with - | Ok () -> { decl with type_layout = layout' } + begin match Layout.sub_with_history layout' decl.type_layout with + | Ok layout' -> { decl with type_layout = layout' } | Error v -> raise (Error (loc, Layout_coherence_check (ty,v))) end @@ -1060,13 +1068,13 @@ let default_decls_layout decls = should be replaced with checks at the places where values of those types are constructed. We've been conservative here in the first version. This is the same issue as with arrows. *) -let check_representable ~reason env loc lloc typ = - match Ctype.type_sort ~reason env typ with +let check_representable ~why env loc lloc typ = + match Ctype.type_sort ~why env typ with (* CR layouts: This is not the right place to default to value. Some callers of this do need defaulting, because they, for example, immediately check if the sort is immediate or void. But we should do that in those places, or as part of our higher-level defaulting story. *) - | Ok s -> Layout.default_to_value (Layout.of_sort s) + | Ok s -> Sort.default_to_value s | Error err -> raise (Error (loc,Layout_sort {lloc; typ; err})) (* The [update_x_layouts] functions infer more precise layouts in the type kind, @@ -1087,14 +1095,14 @@ let update_label_layouts env loc lbls named = in let lbls = List.mapi (fun idx (Types.{ld_type; ld_id; ld_loc} as lbl) -> - check_representable ~reason:(Label_declaration ld_id) + check_representable ~why:(Label_declaration ld_id) env ld_loc Record ld_type; let ld_layout = Ctype.type_layout env ld_type in update idx ld_layout; {lbl with ld_layout} ) lbls in - if List.for_all (fun l -> Layout.(equal void l.ld_layout)) lbls then + if List.for_all (fun l -> Layout.is_void_defaulting l.ld_layout) lbls then raise (Error (loc, Layout_empty_record)) else lbls, false (* CR layouts v5: return true for a record with all voids *) @@ -1106,13 +1114,13 @@ let update_constructor_arguments_layouts env loc cd_args layouts = match cd_args with | Types.Cstr_tuple tys -> List.iteri (fun idx (ty,_) -> - check_representable ~reason:(Constructor_declaration idx) + check_representable ~why:(Constructor_declaration idx) env loc Cstr_tuple ty; layouts.(idx) <- Ctype.type_layout env ty) tys; - cd_args, Array.for_all Layout.is_void layouts + cd_args, Array.for_all Layout.is_void_defaulting layouts | Types.Cstr_record lbls -> let lbls, all_void = update_label_layouts env loc lbls None in - layouts.(0) <- Layout.value; + layouts.(0) <- Layout.value ~why:Boxed_record; Types.Cstr_record lbls, all_void (* This function updates layout stored in kinds with more accurate layouts. @@ -1129,7 +1137,7 @@ let update_decl_layout env dpath decl = let update_record_kind loc lbls rep = match lbls, rep with | [Types.{ld_type; ld_id; ld_loc} as lbl], Record_unboxed -> - check_representable ~reason:(Label_declaration ld_id) + check_representable ~why:(Label_declaration ld_id) env ld_loc Record ld_type; let ld_layout = Ctype.type_layout env ld_type in [{lbl with ld_layout}], Record_unboxed, ld_layout @@ -1142,9 +1150,11 @@ let update_decl_layout env dpath decl = sense to use that here? The use of value feels inaccurate, but I think the code that would look at first looks at the rep. *) let lbls = - List.map (fun lbl -> { lbl with ld_layout = Layout.value }) lbls + List.map (fun lbl -> + { lbl with ld_layout = Layout.value ~why:Float_record_field }) + lbls in - lbls, rep, Layout.value + lbls, rep, Layout.value ~why:Boxed_record | (([] | (_ :: _)), Record_unboxed | _, Record_inlined _) -> assert false in @@ -1156,13 +1166,13 @@ let update_decl_layout env dpath decl = match cd_args with | Cstr_tuple [ty,_] -> begin (* CR layouts: check_representable should return the sort *) - check_representable ~reason:(Constructor_declaration 0) + check_representable ~why:(Constructor_declaration 0) env cd_loc Cstr_tuple ty; let layout = Ctype.type_layout env ty in cstrs, Variant_unboxed, layout end | Cstr_record [{ld_type; ld_id; ld_loc} as lbl] -> begin - check_representable ~reason:(Label_declaration ld_id) + check_representable ~why:(Label_declaration ld_id) env ld_loc Record ld_type; let ld_layout = Ctype.type_layout env ld_type in [{ cstr with Types.cd_args = @@ -1183,9 +1193,7 @@ let update_decl_layout env dpath decl = (idx+1,cstr::cstrs,all_voids && all_void) ) (0,[],true) cstrs in - let layout = - if all_voids then Layout.immediate else Layout.value - in + let layout = Layout.for_boxed_variant ~all_voids in List.rev cstrs, rep, layout | (([] | (_ :: _)), Variant_unboxed | _, Variant_extensible) -> assert false @@ -1194,7 +1202,7 @@ let update_decl_layout env dpath decl = let new_decl, new_layout = match decl.type_kind with | Type_abstract -> decl, decl.type_layout | Type_open -> - let type_layout = Layout.value in + let type_layout = Layout.value ~why:Extensible_variant in { decl with type_layout }, type_layout | Type_record (lbls, rep) -> let lbls, rep, type_layout = update_record_kind decl.type_loc lbls rep in @@ -1284,7 +1292,8 @@ let check_well_founded_manifest env loc path decl = let args = (* The layouts here shouldn't matter for the purposes of [check_well_founded] *) - List.map (fun _ -> Ctype.newvar Layout.any) decl.type_params + List.map (fun _ -> Ctype.newvar (Layout.any ~why:Dummy_layout)) + decl.type_params in check_well_founded env loc path (Path.same path) (Ctype.newconstr path args) @@ -1539,10 +1548,7 @@ let transl_type_decl env rec_flag sdecl_list = layout checks *) List.iter (fun (checks,loc) -> List.iter (fun (ty,layout) -> - match - Ctype.constrain_type_layout ~reason:Dummy_reason_result_ignored - new_env ty layout - with + match Ctype.constrain_type_layout new_env ty layout with | Ok _ -> () | Error err -> let err = Errortrace.unification_error ~trace:[Bad_layout (ty,err)] in @@ -1610,7 +1616,7 @@ let transl_extension_constructor ~scope env type_path type_params | Cstr_tuple args -> List.length args | Cstr_record _ -> 1 in - let layouts = Array.make num_args Layout.any in + let layouts = Array.make num_args (Layout.any ~why:Dummy_layout) in let args, constant = update_constructor_arguments_layouts env sext.pext_loc args layouts in @@ -2142,9 +2148,8 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env sig_decl.type_kind, sig_decl.type_unboxed_default, sig_decl.type_layout else (* CR layouts v2: this is a gross hack. See the comments in the - [Ptyp_package] case of [Typetexp.transl_type_aux]. - This seems just wrong to RAE. *) - let layout = Layout.value in + [Ptyp_package] case of [Typetexp.transl_type_aux]. *) + let layout = Layout.value ~why:Package_hack in (* Layout.(of_attributes ~default:value sdecl.ptype_attributes) *) Type_abstract, false, layout in @@ -2206,7 +2211,7 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env let layout_annotation = layout_of_attributes ~legacy_immediate:false - ~reason:(With_constraint sdecl.ptype_loc) + ~reason:(With_constraint sdecl.ptype_name.txt) sdecl.ptype_attributes in Ctype.end_def(); @@ -2262,13 +2267,14 @@ let approx_type_decl sdecl_list = to write [@@immediate] on declarations. *) layout_of_attributes_default ~legacy_immediate:true ~reason:(Type_declaration (Pident id)) - ~default:Layout.value sdecl.ptype_attributes + ~default:(Layout.value ~why:Default_type_layout) + sdecl.ptype_attributes in let params = List.map (fun (styp,_) -> layout_of_attributes_default ~legacy_immediate:false ~reason:(Type_parameter (Pident id, parameter_name styp)) - ~default:Layout.value + ~default:(Layout.value ~why:Type_argument) styp.ptyp_attributes) sdecl.ptype_params in diff --git a/ocaml/typing/typedecl.mli b/ocaml/typing/typedecl.mli index 5bd71146d56..6bbb84da6f0 100644 --- a/ocaml/typing/typedecl.mli +++ b/ocaml/typing/typedecl.mli @@ -102,12 +102,12 @@ type error = | Multiple_native_repr_attributes | Cannot_unbox_or_untag_type of native_repr_kind | Deep_unbox_or_untag_attribute of native_repr_kind - | Layout_coherence_check of type_expr * Layout.Violation.violation - | Layout_update_check of Path.t * Layout.Violation.violation + | Layout_coherence_check of type_expr * Layout.Violation.t + | Layout_update_check of Path.t * Layout.Violation.t | Layout_sort of { lloc : layout_sort_loc ; typ : type_expr - ; err : Layout.Violation.violation + ; err : Layout.Violation.t } | Layout_empty_record | Separability of Typedecl_separability.error diff --git a/ocaml/typing/typedecl_separability.ml b/ocaml/typing/typedecl_separability.ml index 618fe309556..d0126f258c9 100644 --- a/ocaml/typing/typedecl_separability.ml +++ b/ocaml/typing/typedecl_separability.ml @@ -479,10 +479,11 @@ let worst_msig decl = List.map (fun _ -> Deepsep) decl.type_params array optimization and this entire file at that point. *) let msig_of_external_type env decl = let check_layout = - Ctype.check_decl_layout ~reason:Dummy_reason_result_ignored env decl + Ctype.check_decl_layout env decl in - if Result.is_error (check_layout Layout.value) - || Result.is_ok (check_layout Layout.immediate64) + if Result.is_error (check_layout (Layout.value ~why:Separability_check)) + || Result.is_ok + (check_layout (Layout.immediate64 ~why:Separability_check)) then best_msig decl else worst_msig decl diff --git a/ocaml/typing/typemod.ml b/ocaml/typing/typemod.ml index 9d2bb045b40..9d0756ec531 100644 --- a/ocaml/typing/typemod.ml +++ b/ocaml/typing/typemod.ml @@ -576,10 +576,12 @@ let merge_constraint initial_env loc sg lid constr = { type_params = (* layout any is fine on the params because they get thrown away below *) - List.map (fun _ -> Btype.newgenvar Layout.any) sdecl.ptype_params; + List.map + (fun _ -> Btype.newgenvar (Layout.any ~why:Dummy_layout)) + sdecl.ptype_params; type_arity = arity; type_kind = Type_abstract; - type_layout = Layout.value; + type_layout = Layout.value ~why:(Unknown "merge_constraint"); type_private = Private; type_manifest = None; type_variance = @@ -2636,7 +2638,8 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = near the top of [execute_phrase] in [opttoploop.ml]. *) let expr, sort = Builtin_attributes.warning_scope attrs - (fun () -> Typecore.type_representable_expression env sexpr) + (fun () -> Typecore.type_representable_expression + ~why:Structure_item_expression env sexpr) in Tstr_eval (expr, sort, attrs), [], shape_map, env | Pstr_value(rec_flag, sdefs) -> @@ -2661,9 +2664,9 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = (* CR layouts v5: this layout check has the effect of defaulting the sort of top-level bindings to value, which will change. *) - if not (Layout.(equate (of_sort sort) value)) then - raise (Error (loc, env, - Toplevel_nonvalue (Ident.name id,sort))) + if not Sort.(equate sort value) + then raise (Error (loc, env, + Toplevel_nonvalue (Ident.name id,sort))) ) modes; let (first_loc, _, _) = List.hd modes in @@ -3167,7 +3170,8 @@ let type_package env m p fl = List.iter (fun (n, ty) -> (* CR layouts v5: relax value requirement. *) - try Ctype.unify env ty (Ctype.newvar Layout.value) + try Ctype.unify env ty + (Ctype.newvar (Layout.value ~why:Structure_element)) with Ctype.Unify _ -> raise (Error(modl.mod_loc, env, Scoping_pack (n,ty)))) fl'; @@ -3615,7 +3619,7 @@ let report_error ~loc _env = function | Toplevel_nonvalue (id, sort) -> Location.errorf ~loc "@[Top-level module bindings must have layout value, but@ \ - %s has layout@ %a.@]" id Layout.format (Layout.of_sort sort) + %s has layout@ %a.@]" id Sort.format sort let report_error env ~loc err = Printtyp.wrap_printing_env ~error:true env diff --git a/ocaml/typing/typeopt.ml b/ocaml/typing/typeopt.ml index 3b4df782f68..86c501f940c 100644 --- a/ocaml/typing/typeopt.ml +++ b/ocaml/typing/typeopt.ml @@ -26,7 +26,7 @@ open Lambda the void sanity check. When we're ready to take that out, remove the errors stuff. *) type error = - Non_value_layout of type_expr * Layout.Violation.violation + Non_value_layout of type_expr * Layout.Violation.t exception Error of Location.t * error @@ -80,11 +80,10 @@ let is_always_gc_ignorable env ty = immediate64 types as gc_ignorable, because bytecode is intended to be platform independent. *) if !Clflags.native_code && Sys.word_size = 64 - then Layout.immediate64 - else Layout.immediate + then Layout.immediate64 ~why:Gc_ignorable_check + else Layout.immediate ~why:Gc_ignorable_check in - Result.is_ok - (Ctype.check_type_layout ~reason:V1_safety_check env ty layout) + Result.is_ok (Ctype.check_type_layout env ty layout) let maybe_pointer_type env ty = let ty = scrape_ty env ty in @@ -255,20 +254,20 @@ let rec value_kind env ~loc ~visited ~depth ~num_nodes_visited ty This should be understood, but for now I'm doing the simple fall back thing so I can test the performance difference. *) - match Ctype.check_type_layout ~reason:V1_safety_check env scty Layout.value + match Ctype.check_type_layout env scty (Layout.value ~why:V1_safety_check) with | Ok _ -> () | Error _ -> match - Ctype.(check_type_layout ~reason:V1_safety_check env - (correct_levels ty) Layout.value) + Ctype.(check_type_layout env + (correct_levels ty) (Layout.value ~why:V1_safety_check)) with | Ok _ -> () - | Error e -> - if e.missing_cmi then - () (* CR layouts v1.5: stop allowing missing cmis *) - else - raise (Error (loc, Non_value_layout (ty, e))) + | Error violation -> + if not (Layout.Violation.is_missing_cmi violation) + then raise (Error (loc, Non_value_layout (ty, violation))) + (* CR layouts v1.5: stop allowing missing cmis *) + end; match get_desc scty with | Tconstr(p, _, _) when Path.same p Predef.path_int -> @@ -487,7 +486,18 @@ let value_kind env loc ty = (* CR layouts v2: We'll have other layouts. Think about what to do with the sanity check in value_kind. *) -let layout env loc ty = Lambda.Pvalue (value_kind env loc ty) +let rec layout env loc ty = + match get_desc (scrape_ty env ty) with + | Tconstr(p, args, _) when Path.same p Predef.path_unboxed_pair -> + let layouts = List.map (layout env loc) args in + Punboxed_product layouts + | Tconstr(p, args, _) when Path.same p Predef.path_unboxed_triple -> + let layouts = List.map (layout env loc) args in + Punboxed_product layouts + | Tconstr(p, _, _) when Path.same p Predef.path_void -> + Punboxed_product [] + | _ -> + Lambda.Pvalue (value_kind env loc ty) let function_return_layout env loc ty = match is_function_type env ty with @@ -538,7 +548,7 @@ let value_kind_union (k1 : Lambda.value_kind) (k2 : Lambda.value_kind) = if Lambda.equal_value_kind k1 k2 then k1 else Pgenval -let layout_union l1 l2 = +let rec layout_union l1 l2 = match l1, l2 with | Pbottom, l | l, Pbottom -> l @@ -547,7 +557,11 @@ let layout_union l1 l2 = | Punboxed_float, Punboxed_float -> Punboxed_float | Punboxed_int bi1, Punboxed_int bi2 -> if equal_boxed_integer bi1 bi2 then l1 else Ptop - | (Ptop | Pvalue _ | Punboxed_float | Punboxed_int _), _ -> + | Punboxed_product layouts1, Punboxed_product layouts2 -> + if List.compare_lengths layouts1 layouts2 <> 0 then Ptop + else Punboxed_product (List.map2 layout_union layouts1 layouts2) + | (Ptop | Pvalue _ | Punboxed_float | Punboxed_int _ | Punboxed_product _), + _ -> Ptop (* Error report *) diff --git a/ocaml/typing/types.mli b/ocaml/typing/types.mli index 84e760d6d01..8128337d97e 100644 --- a/ocaml/typing/types.mli +++ b/ocaml/typing/types.mli @@ -787,7 +787,7 @@ type label_description = (** The special value we assign to lbl_pos for label descriptions corresponding to void types, because they can't sensibly be projected. - CR-someday layouts: This should be removed once we have unarization, as it + CR layouts v5: This should be removed once we have unarization, as it will be up to a later stage of the compiler to erase void. *) val lbl_pos_void : int diff --git a/ocaml/typing/typetexp.ml b/ocaml/typing/typetexp.ml index ae0ebcd2ae3..9b062cebebc 100644 --- a/ocaml/typing/typetexp.ml +++ b/ocaml/typing/typetexp.ml @@ -57,9 +57,9 @@ type error = | Unsupported_extension of Language_extension.t | Polymorphic_optional_param | Non_value of - {vloc : value_loc; typ : type_expr; err : Layout.Violation.violation} + {vloc : value_loc; typ : type_expr; err : Layout.Violation.t} | Non_sort of - {vloc : sort_loc; typ : type_expr; err : Layout.Violation.violation} + {vloc : sort_loc; typ : type_expr; err : Layout.Violation.t} exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -208,7 +208,7 @@ end = struct ~finally:(fun () -> univars := old_univars) let make_poly_univars vars = - List.map (fun name -> name, newvar ~name Layout.value) vars + List.map (fun name -> name, newvar ~name (Layout.value ~why:Univar)) vars let check_poly_univars env loc vars = vars |> List.iter (fun (_, v) -> generalize v); @@ -294,7 +294,7 @@ end = struct TyVarMap.iter (fun name (ty, loc) -> if flavor = Unification || is_in_scope name then - let v = new_global_var Layout.any in + let v = new_global_var (Layout.any ~why:Dummy_layout) in let snap = Btype.snapshot () in if try unify env v ty; true with _ -> Btype.backtrack snap; false then try @@ -304,7 +304,7 @@ end = struct raise(Error(loc, env, Unbound_type_variable ("'"^name, get_in_scope_names ()))); - let v2 = new_global_var Layout.any in + let v2 = new_global_var (Layout.any ~why:Dummy_layout) in r := (loc, v, v2) :: !r; add name v2) !used_variables; @@ -441,8 +441,10 @@ and transl_type_aux env policy mode styp = | None -> match styp.ptyp_desc with Ptyp_any -> - let ty = TyVarEnv.new_anon_var styp.ptyp_loc env Layout.any policy in - ctyp Ttyp_any ty + let ty = + TyVarEnv.new_anon_var styp.ptyp_loc env (Layout.any ~why:Wildcard) policy + in + ctyp Ttyp_any ty | Ptyp_var name -> let ty = if not (valid_tyvar_name name) then @@ -450,7 +452,8 @@ and transl_type_aux env policy mode styp = begin try TyVarEnv.lookup_local name with Not_found -> - let v = TyVarEnv.new_var ~name Layout.any policy in + let v = TyVarEnv.new_var ~name + (Layout.any ~why:Unification_var) policy in TyVarEnv.remember_used name v styp.ptyp_loc; v end @@ -490,8 +493,8 @@ and transl_type_aux env policy mode styp = to have a representable layout. See comment in [Ctype.filter_arrow]. *) begin match - Ctype.type_sort ~reason:Function_argument env arg_ty, - Ctype.type_sort ~reason:Function_result env ret_cty.ctyp_type + Ctype.type_sort ~why:Function_argument env arg_ty, + Ctype.type_sort ~why:Function_result env ret_cty.ctyp_type with | Ok _, Ok _ -> () | Error e, _ -> @@ -515,8 +518,8 @@ and transl_type_aux env policy mode styp = List.iter (fun {ctyp_type; ctyp_loc} -> (* CR layouts v5: remove value requirement *) match - constrain_type_layout ~reason:(Fixed_layout Tuple_element) - env ctyp_type Layout.value + constrain_type_layout + env ctyp_type (Layout.value ~why:Tuple_element) with | Ok _ -> () | Error e -> @@ -615,10 +618,13 @@ and transl_type_aux env policy mode styp = (row_fields row) in (* NB: row is always non-static here; more is thus never Tnil *) - let more = TyVarEnv.new_var Layout.value policy in + let more = + TyVarEnv.new_var (Layout.value ~why:Row_variable) policy + in let row = create_row ~fields ~more - ~closed:true ~fixed:None ~name:(Some (path, ty_args)) in + ~closed:true ~fixed:None ~name:(Some (path, ty_args)) + in newty (Tvariant row) | Tobject (fi, _) -> let _, tv = flatten_fields fi in @@ -640,7 +646,7 @@ and transl_type_aux env policy mode styp = ty with Not_found -> if !Clflags.principal then begin_def (); - let t = newvar Layout.any in + let t = newvar (Layout.any ~why:Dummy_layout) in TyVarEnv.remember_used alias t styp.ptyp_loc; let ty = transl_type env policy mode st in begin try unify_var env t ty.ctyp_type with Unify err -> @@ -667,7 +673,7 @@ and transl_type_aux env policy mode styp = let name = ref None in let mkfield l f = newty (Tvariant (create_row ~fields:[l,f] - ~more:(newvar Layout.value) + ~more:(newvar (Layout.value ~why:Row_variable)) ~closed:true ~fixed:None ~name:None)) in let hfields = Hashtbl.create 17 in let add_typed_field loc l f = @@ -699,8 +705,8 @@ and transl_type_aux env policy mode styp = (* CR layouts: at some point we'll allow different layouts in polymorphic variants. *) match - constrain_type_layout ~reason:Dummy_reason_result_ignored - env ctyp_type Layout.value + constrain_type_layout env ctyp_type + (Layout.value ~why:Polymorphic_variant_field) with | Ok _ -> () | Error e -> @@ -768,8 +774,10 @@ and transl_type_aux env policy mode styp = create_row ~fields ~more ~closed:(closed = Closed) ~fixed:None ~name in let more = - if Btype.static_row (make_row (newvar Layout.value)) then newty Tnil - else TyVarEnv.new_var Layout.value policy + if Btype.static_row + (make_row (newvar (Layout.value ~why:Row_variable))) + then newty Tnil + else TyVarEnv.new_var (Layout.value ~why:Row_variable) policy in let ty = newty (Tvariant (make_row more)) in ctyp (Ttyp_variant (tfields, closed, present)) ty @@ -788,7 +796,7 @@ and transl_type_aux env policy mode styp = let ty_list = TyVarEnv.check_poly_univars env styp.ptyp_loc new_univars in let ty_list = List.filter (fun v -> deep_occur v ty) ty_list in let ty' = Btype.newgenty (Tpoly(ty, ty_list)) in - unify_var env (newvar Layout.any) ty'; + unify_var env (newvar (Layout.any ~why:Dummy_layout)) ty'; ctyp (Ttyp_poly (vars, cty)) ty' | Ptyp_package (p, l) -> (* CR layouts: right now we're doing a real gross hack where we demand @@ -808,8 +816,7 @@ and transl_type_aux env policy mode styp = ) l in List.iter (fun (s,{ctyp_type=ty}) -> match - Ctype.constrain_type_layout ~reason:(Fixed_layout Package_hack) - env ty Layout.value + Ctype.constrain_type_layout env ty (Layout.value ~why:Package_hack) with | Ok _ -> () | Error e -> @@ -855,8 +862,8 @@ and transl_fields env policy o fields = in begin match - constrain_type_layout ~reason:(Fixed_layout Object_field) - env ty1.ctyp_type Layout.value + constrain_type_layout + env ty1.ctyp_type (Layout.value ~why:Object_field) with | Ok _ -> () | Error e -> @@ -903,7 +910,7 @@ and transl_fields env policy o fields = let ty_init = match o with | Closed -> newty Tnil - | Open -> TyVarEnv.new_var Layout.value policy + | Open -> TyVarEnv.new_var (Layout.value ~why:Row_variable) policy in let ty = List.fold_left (fun ty (s, ty') -> newty (Tfield (s, field_public, ty', ty))) ty_init fields in @@ -997,6 +1004,11 @@ let transl_type_scheme env styp = begin_def(); let typ = transl_simple_type env ~closed:false Alloc_mode.Global styp in end_def(); + (* This next line is very important: it stops [val] and [external] + declarations from having undefaulted layout variables. Without + this line, we might accidentally export a layout-flexible definition + from a compilation unit, which would lead to miscompilation. *) + remove_mode_and_layout_variables typ.ctyp_type; generalize typ.ctyp_type; typ diff --git a/ocaml/typing/typetexp.mli b/ocaml/typing/typetexp.mli index 5af22af190a..df9415af7b9 100644 --- a/ocaml/typing/typetexp.mli +++ b/ocaml/typing/typetexp.mli @@ -98,9 +98,9 @@ type error = | Unsupported_extension of Language_extension.t | Polymorphic_optional_param | Non_value of - {vloc : value_loc; typ : type_expr; err : Layout.Violation.violation} + {vloc : value_loc; typ : type_expr; err : Layout.Violation.t} | Non_sort of - {vloc : sort_loc; typ : type_expr; err : Layout.Violation.violation} + {vloc : sort_loc; typ : type_expr; err : Layout.Violation.t} exception Error of Location.t * Env.t * error diff --git a/ocaml/utils/misc.ml b/ocaml/utils/misc.ml index 4f747f4bb05..5ca4d768b66 100644 --- a/ocaml/utils/misc.ml +++ b/ocaml/utils/misc.ml @@ -192,6 +192,10 @@ module Stdlib = struct module Option = struct type 'a t = 'a option + let first_some a b = match a with + | Some _ -> a + | None -> b () + let print print_contents ppf t = match t with | None -> Format.pp_print_string ppf "None" diff --git a/ocaml/utils/misc.mli b/ocaml/utils/misc.mli index fbfecce5e69..ee860ba0963 100644 --- a/ocaml/utils/misc.mli +++ b/ocaml/utils/misc.mli @@ -99,7 +99,7 @@ module Stdlib : sig (** The lexicographic order supported by the provided order. There is no constraint on the relative lengths of the lists. *) - val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + val equal : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool (** Returns [true] if and only if the given lists have the same length and content with respect to the given equality function. *) @@ -149,6 +149,9 @@ module Stdlib : sig module Option : sig type 'a t = 'a option + (* short circuits if the first argument really is a [Some] *) + val first_some : 'a option -> (unit -> 'a option) -> 'a option + val print : (Format.formatter -> 'a -> unit) -> Format.formatter diff --git a/up.ml b/up.ml new file mode 100644 index 00000000000..e14d3162745 --- /dev/null +++ b/up.ml @@ -0,0 +1,308 @@ +external make_unboxed_pair_v_v : 'a -> 'b -> ('a, 'b) unboxed_pair = "%make_unboxed_pair_v_v" +external unboxed_pair_field_0_v_v : ('a, 'b) unboxed_pair -> 'a = "%unboxed_pair_field_0_v_v" +external unboxed_pair_field_1_v_v : ('a, 'b) unboxed_pair -> 'b = "%unboxed_pair_field_1_v_v" + +let f i x y = + let p = make_unboxed_pair_v_v x y in + if i < 0 then unboxed_pair_field_0_v_v p + else unboxed_pair_field_1_v_v p + +external make_unboxed_pair_vup_vup : + ('a, 'b) unboxed_pair -> ('c, 'd) unboxed_pair + -> (('a, 'b) unboxed_pair, ('c, 'd) unboxed_pair) unboxed_pair + = "%make_unboxed_pair_vup_vup" + +external unboxed_pair_field_0_vup_vup : + (('a, 'b) unboxed_pair, _) unboxed_pair + -> ('a, 'b) unboxed_pair = "%unboxed_pair_field_0_vup_vup" + +let g i x y = + let p = make_unboxed_pair_v_v x y in + let q = make_unboxed_pair_vup_vup p p in + let p_again = unboxed_pair_field_0_vup_vup q in + if i < 0 then unboxed_pair_field_0_v_v p_again + else unboxed_pair_field_1_v_v p_again + +external unboxed_pair_field_1_vup_vup : + (_, ('a, 'b) unboxed_pair) unboxed_pair + -> ('a, 'b) unboxed_pair = "%unboxed_pair_field_1_vup_vup" + +let h i x y = + let p = make_unboxed_pair_v_v x y in + let p' = make_unboxed_pair_v_v y x in + let q = make_unboxed_pair_vup_vup p p' in + let r = + if i < 0 then unboxed_pair_field_0_vup_vup q + else unboxed_pair_field_1_vup_vup q + in + if i < 0 then unboxed_pair_field_0_v_v r + else unboxed_pair_field_1_v_v r + +external make_unboxed_pair_i_i : 'a -> 'b -> ('a, 'b) unboxed_pair = "%make_unboxed_pair_i_i" +external unboxed_pair_field_0_i_i : ('a, 'b) unboxed_pair -> 'a = "%unboxed_pair_field_0_i_i" +external unboxed_pair_field_1_i_i : ('a, 'b) unboxed_pair -> 'b = "%unboxed_pair_field_1_i_i" + +let[@inline never] takes_unboxed_pair (p : (int, int) unboxed_pair) = + let p0 = unboxed_pair_field_0_i_i p in + let p1 = unboxed_pair_field_1_i_i p in + p0 + p1 + +let caller x y = + let p = make_unboxed_pair_i_i x y in + takes_unboxed_pair p + +let[@inline never] takes_two_unboxed_pairs + (p : (int, int) unboxed_pair) + (q : (int, int) unboxed_pair) = + let p0 = unboxed_pair_field_0_i_i p in + let p1 = unboxed_pair_field_1_i_i p in + let q0 = unboxed_pair_field_0_i_i q in + let q1 = unboxed_pair_field_1_i_i q in + p0 + 10*p1 + 100*q0 + 1000*q1 + +let caller2 x y = + let p = make_unboxed_pair_i_i x y in + let q = make_unboxed_pair_i_i y x in + takes_two_unboxed_pairs p q + +let make_partial x y = + let p = make_unboxed_pair_i_i x y in + let partial = takes_two_unboxed_pairs p in + let q = make_unboxed_pair_i_i y x in + (Sys.opaque_identity partial) q + +let () = + Printf.printf "%d\n%!" (make_partial 1 2) + +let[@inline never] takes_three_unboxed_pairs + (p : (int, int) unboxed_pair) + (q : (int, int) unboxed_pair) + (r : (int, int) unboxed_pair) = + let p0 = unboxed_pair_field_0_i_i p in + let p1 = unboxed_pair_field_1_i_i p in + let q0 = unboxed_pair_field_0_i_i q in + let q1 = unboxed_pair_field_1_i_i q in + let r0 = unboxed_pair_field_0_i_i r in + let r1 = unboxed_pair_field_1_i_i r in + p0 + 10*p1 + 100*q0 + 1000*q1 + 10000*r0 + 100000*r1 + +let make_partial3 a b c d e f = + let p = make_unboxed_pair_i_i a b in + let q = make_unboxed_pair_i_i c d in + let r = make_unboxed_pair_i_i e f in + let partial1 = takes_three_unboxed_pairs p in + let partial2 = (Sys.opaque_identity partial1) q in + (Sys.opaque_identity partial2) r + +let () = + Printf.printf "%d\n%!" (make_partial3 1 2 3 4 5 6) + +let[@inline never] returns_unboxed_pair_not_inlined x = + if x < 0 then make_unboxed_pair_i_i x x + else make_unboxed_pair_i_i (x + 1) (x + 2) + +let[@inline] returns_unboxed_pair_inlined x = + if x < 0 then make_unboxed_pair_i_i x x + else make_unboxed_pair_i_i (x + 1) (x + 2) + +let call_function_returning_unboxed_pair x = + let p1 = returns_unboxed_pair_not_inlined x in + let p2 = returns_unboxed_pair_inlined x in + let p1_0 = unboxed_pair_field_0_i_i p1 in + let p1_1 = unboxed_pair_field_1_i_i p1 in + let p2_0 = unboxed_pair_field_0_i_i p2 in + let p2_1 = unboxed_pair_field_1_i_i p2 in + p1_0 + p1_1 + p2_0 + p2_1 + +let () = + Printf.printf "%d\n%!" (call_function_returning_unboxed_pair 42) + +external void : unit -> void = "%void" + +let void_const (v : void) = 42 + +let void0 (v : void) x = x + +let void1a (v : void) x y = x +let void1b (v : void) x y = y + +let void2a x (v : void) y = x +let void2b x (v : void) y = y + +let void3a x y (v : void) = x +let void3b x y (v : void) = y + +let apply_void1a_no_wrapper x y = + let p = (Sys.opaque_identity void1a) (void ()) in + p x y + +let () = + Printf.printf "%d (expected 1)\n%!" (apply_void1a_no_wrapper 1 2) + +let[@inline never] two_voids_const (v : void) (v : void) = 42 +let[@inline never] two_voids_const_side1 (v : void) = + Printf.printf "foo\n%!"; fun (v : void) -> 42 + +let[@inline never] two_voids_const_side2 (v : void) (v : void) = + Printf.printf "bar\n%!"; + 42 + +(* With partial applications concealed from flambda *) +let () = + let p = (Sys.opaque_identity two_voids_const) (void ()) in + Printf.printf "%d (expected 42)\n%!" (p (void ())); + let p = (Sys.opaque_identity two_voids_const_side1) (void ()) in + Printf.printf "after definition\n%!"; + Printf.printf "%d (expected 42)\n%!" (p (void ())); + let p = (Sys.opaque_identity two_voids_const_side2) (void ()) in + Printf.printf "after definition\n%!"; + Printf.printf "%d (expected 42)\n%!" (p (void ())) + +(* With partial applications visible to flambda (From_lambda) *) +let () = + let p = Sys.opaque_identity (two_voids_const (void ())) in + Printf.printf "%d (expected 42)\n%!" (p (void ())); + let p = Sys.opaque_identity (two_voids_const_side1 (void ())) in + Printf.printf "after definition\n%!"; + Printf.printf "%d (expected 42)\n%!" (p (void ())); + let p = Sys.opaque_identity (two_voids_const_side2 (void ())) in + Printf.printf "after definition\n%!"; + Printf.printf "%d (expected 42)\n%!" (p (void ())) + +(* With partial applications visible to flambda (Simplify) *) +let[@inline] to_inline two_voids_const two_voids_const_side1 + two_voids_const_side2 = + let p = Sys.opaque_identity (two_voids_const (void ())) in + Printf.printf "%d (expected 42)\n%!" (p (void ())); + let p = Sys.opaque_identity (two_voids_const_side1 (void ())) in + Printf.printf "after definition\n%!"; + Printf.printf "%d (expected 42)\n%!" (p (void ())); + let p = Sys.opaque_identity (two_voids_const_side2 (void ())) in + Printf.printf "after definition\n%!"; + Printf.printf "%d (expected 42)\n%!" (p (void ())) + +let () = + to_inline two_voids_const two_voids_const_side1 two_voids_const_side2 + +(* Overapplications concealed from flambda *) +let () = + Printf.printf "OVERAPP1\n%!"; + let x = (Sys.opaque_identity two_voids_const) (void ()) (void ()) in + Printf.printf "%d (expected 42)\n%!" x; + let x = (Sys.opaque_identity two_voids_const_side1) (void ()) (void ()) in + Printf.printf "%d (expected 42)\n%!" x; + let x = (Sys.opaque_identity two_voids_const_side2) (void ()) (void ()) in + Printf.printf "%d (expected 42)\n%!" x + +(* Overapplications visible to flambda *) +let () = + Printf.printf "OVERAPP2\n%!"; + let x = two_voids_const (void ()) (void ()) in + Printf.printf "%d (expected 42)\n%!" x; + let x = two_voids_const_side1 (void ()) (void ()) in + Printf.printf "%d (expected 42)\n%!" x; + let x = two_voids_const_side2 (void ()) (void ()) in + Printf.printf "%d (expected 42)\n%!" x + +(* Overapplications visible to simplify only *) +let[@inline always] g (f : void -> void -> int) : int = f (void ()) (void ()) +let () = + Printf.printf "OVERAPP3\n%!"; + let x = g two_voids_const in + Printf.printf "%d (expected 42)\n%!" x; + let x = g two_voids_const_side1 in + Printf.printf "%d (expected 42)\n%!" x; + let x = g two_voids_const_side2 in + Printf.printf "%d (expected 42)\n%!" x + +(* From above: with partial applications visible to flambda (From_lambda), + but using void arguments extracted from unboxed products *) +external make_unboxed_pair_o_o : void -> void -> (void, void) unboxed_pair = + "%make_unboxed_pair_o_o" +external unboxed_pair_field_0_o_o : (void, void) unboxed_pair -> void = + "%unboxed_pair_field_0_o_o" +external unboxed_pair_field_1_o_o : (void, void) unboxed_pair -> void = + "%unboxed_pair_field_1_o_o" + +let[@inline never] void_from_product () = + let p = make_unboxed_pair_o_o (void ()) (void ()) in + unboxed_pair_field_0_o_o p + +let[@inline] void_from_product_inlined () = + let p = make_unboxed_pair_o_o (void ()) (void ()) in + unboxed_pair_field_0_o_o p + +let () = + let p = Sys.opaque_identity (two_voids_const (void_from_product ())) in + Printf.printf "%d (expected 42)\n%!" (p (void_from_product ())); + let p = Sys.opaque_identity (two_voids_const_side1 (void_from_product ())) in + Printf.printf "after definition\n%!"; + Printf.printf "%d (expected 42)\n%!" (p (void_from_product ())); + let p = Sys.opaque_identity (two_voids_const_side2 (void_from_product ())) in + Printf.printf "after definition\n%!"; + Printf.printf "%d (expected 42)\n%!" (p (void_from_product ())) + +let () = + let p = Sys.opaque_identity (two_voids_const (void_from_product_inlined ())) in + Printf.printf "%d (expected 42)\n%!" (p (void_from_product_inlined ())); + let p = Sys.opaque_identity (two_voids_const_side1 (void_from_product_inlined ())) in + Printf.printf "after definition\n%!"; + Printf.printf "%d (expected 42)\n%!" (p (void_from_product_inlined ())); + let p = Sys.opaque_identity (two_voids_const_side2 (void_from_product_inlined ())) in + Printf.printf "after definition\n%!"; + Printf.printf "%d (expected 42)\n%!" (p (void_from_product_inlined ())) + +(* version without printing to declutter Cmm *) +let[@inline never] returns_unboxed_pair_of_voids_not_inlined0 x = + make_unboxed_pair_o_o (void ()) (void ()) + +let[@inline never] returns_unboxed_pair_of_voids_not_inlined x = + if x < 0 then make_unboxed_pair_o_o (void ()) (void ()) + else ( + Printf.printf "foo\n%!"; + make_unboxed_pair_o_o (void ()) (void ()) + ) + +let[@inline] returns_unboxed_pair_of_voids_inlined x = + if x < 0 then make_unboxed_pair_o_o (void ()) (void ()) + else ( + Printf.printf "foo2\n%!"; + make_unboxed_pair_o_o (void ()) (void ()) + ) + +let print_foo (_ : void) = Printf.printf "FOO\n%!" + +let[@inline never] call_functions_returning_unboxed_pair_of_voids x = + let p1 = returns_unboxed_pair_of_voids_not_inlined x in + let p2 = returns_unboxed_pair_of_voids_inlined x in + print_foo (unboxed_pair_field_0_o_o p1); + print_foo (unboxed_pair_field_1_o_o p1); + print_foo (unboxed_pair_field_0_o_o p2); + print_foo (unboxed_pair_field_1_o_o p2) + +let () = call_functions_returning_unboxed_pair_of_voids 100 +let () = call_functions_returning_unboxed_pair_of_voids (-100) + +external make_unboxed_triple_o_i_o + : void -> int -> void -> (void, int, void) unboxed_triple = + "%make_unboxed_triple_o_i_o" + +let[@inline never] returns_unboxed_triple_of_void_int_void_not_inlined x = + make_unboxed_triple_o_i_o (void ()) x (void ()) + +let[@inline never] ccatch c a b = + let[@local] sub p = + let a = unboxed_pair_field_0_v_v p in + let b = unboxed_pair_field_1_v_v p in + a - b + in + if c then + let p1 = make_unboxed_pair_v_v a b in + sub p1 + else + let p2 = make_unboxed_pair_v_v b a in + sub p2 + +let () = + Printf.printf "%d\n%!" (ccatch true 1 2); + Printf.printf "%d\n%!" (ccatch false 1 2)