diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml index 47c30593f90..e3efd881f8c 100644 --- a/middle_end/closure/closure.ml +++ b/middle_end/closure/closure.ml @@ -1099,6 +1099,7 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) ap_loc=loc; ap_func=(Lvar funct_var); ap_args=internal_args; + ap_result_layout=Lambda.layout_top; ap_region_close=Rc_normal; ap_mode=ret_mode; ap_tailcall=Default_tailcall; @@ -1165,7 +1166,7 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) fail_if_probe ~probe "Unknown function"; (Ugeneric_apply(ufunct, uargs, (pos, mode), dbg), Value_unknown) end - | Lsend(kind, met, obj, args, pos, mode, loc) -> + | Lsend(kind, met, obj, args, pos, mode, loc, _result_layout) -> let (umet, _) = close env met in let (uobj, _) = close env obj in let dbg = Debuginfo.from_location loc in diff --git a/middle_end/flambda/closure_conversion.ml b/middle_end/flambda/closure_conversion.ml index e52c4c38135..3034fead7f1 100644 --- a/middle_end/flambda/closure_conversion.ml +++ b/middle_end/flambda/closure_conversion.ml @@ -329,7 +329,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = in Let_rec (defs, close t env body) end - | Lsend (kind, meth, obj, args, reg_close, mode, loc) -> + | Lsend (kind, meth, obj, args, reg_close, mode, loc, _layout) -> let meth_var = Variable.create Names.meth in let obj_var = Variable.create Names.obj in let dbg = Debuginfo.from_location loc in diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml index a3ca9ad8d47..a992fee9b56 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml @@ -1053,6 +1053,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) | Lapply { ap_func; ap_args; + ap_result_layout; ap_region_close; ap_mode; ap_loc; @@ -1063,7 +1064,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) } -> (* Note that we don't need kind information about [ap_args] since we already have it on the corresponding [Simple]s in the environment. *) - maybe_insert_let_cont "apply_result" Lambda.layout_top k acc env ccenv + maybe_insert_let_cont "apply_result" ap_result_layout k acc env ccenv (fun acc env ccenv k -> cps_tail_apply acc env ccenv ap_func ap_args ap_region_close ap_mode ap_loc ap_inlined ap_probe k k_exn) @@ -1254,7 +1255,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let body acc ccenv = cps_tail acc body_env ccenv body k k_exn in CC.close_let_cont acc ccenv ~name:continuation ~is_exn_handler:false ~params ~recursive ~body ~handler) - | Lsend (meth_kind, meth, obj, args, pos, mode, loc) -> + | Lsend (meth_kind, meth, obj, args, pos, mode, loc, layout) -> cps_non_tail_simple acc env ccenv obj (fun acc env ccenv obj -> cps_non_tail_var "meth" acc env ccenv meth @@ -1262,8 +1263,8 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) (fun acc env ccenv meth -> cps_non_tail_list acc env ccenv args (fun acc env ccenv args -> - maybe_insert_let_cont "send_result" Lambda.layout_top k acc env - ccenv (fun acc env ccenv k -> + maybe_insert_let_cont "send_result" layout k acc env ccenv + (fun acc env ccenv k -> let exn_continuation : IR.exn_continuation = { exn_handler = k_exn; extra_args = extra_args_for_exn_continuation env k_exn diff --git a/ocaml/bytecomp/bytegen.ml b/ocaml/bytecomp/bytegen.ml index 7953a15456f..b9c22eefbb9 100644 --- a/ocaml/bytecomp/bytegen.ml +++ b/ocaml/bytecomp/bytegen.ml @@ -591,7 +591,7 @@ let rec comp_expr env exp sz cont = (Kapply nargs :: cont1)) end end - | Lsend(kind, met, obj, args, rc, _, _) -> + | Lsend(kind, met, obj, args, rc, _, _, _) -> assert (kind <> Cached); let nargs = List.length args + 1 in let getmethod, args' = @@ -994,7 +994,7 @@ let rec comp_expr env exp sz cont = match lam with | Lprim(prim, _, _) -> preserve_tailcall_for_prim prim | Lapply {ap_region_close=rc; _} - | Lsend(_, _, _, _, rc, _, _) -> + | Lsend(_, _, _, _, rc, _, _, _) -> not (is_nontail rc) | _ -> true in @@ -1005,7 +1005,7 @@ let rec comp_expr env exp sz cont = let info = match lam with Lapply{ap_args = args} -> Event_return (List.length args) - | Lsend(_, _, _, args, _, _, _) -> + | Lsend(_, _, _, args, _, _, _, _) -> Event_return (List.length args + 1) | Lprim(_,args,_) -> Event_return (List.length args) | _ -> Event_other diff --git a/ocaml/lambda/lambda.ml b/ocaml/lambda/lambda.ml index 4ad8a31327d..54af41afe68 100644 --- a/ocaml/lambda/lambda.ml +++ b/ocaml/lambda/lambda.ml @@ -442,7 +442,7 @@ type lambda = | Lassign of Ident.t * lambda | Lsend of meth_kind * lambda * lambda * lambda list - * region_close * alloc_mode * scoped_location + * region_close * alloc_mode * scoped_location * layout | Levent of lambda * lambda_event | Lifused of Ident.t * lambda | Lregion of lambda @@ -476,6 +476,7 @@ and lambda_for = and lambda_apply = { ap_func : lambda; ap_args : lambda list; + ap_result_layout : layout; ap_region_close : region_close; ap_mode : alloc_mode; ap_loc : scoped_location; @@ -565,6 +566,7 @@ let layout_string = Pvalue Pgenval let layout_boxedint bi = Pvalue (Pboxedintval bi) let layout_lazy = Pvalue Pgenval let layout_lazy_contents = Pvalue Pgenval +let layout_any_value = Pvalue Pgenval let layout_top = Pvalue Pgenval @@ -650,8 +652,8 @@ let make_key e = Lsequence (tr_rec env e1,tr_rec env e2) | Lassign (x,e) -> Lassign (x,tr_rec env e) - | Lsend (m,e1,e2,es,pos,mo,_loc) -> - Lsend (m,tr_rec env e1,tr_rec env e2,tr_recs env es,pos,mo,Loc_unknown) + | Lsend (m,e1,e2,es,pos,mo,_loc,layout) -> + Lsend (m,tr_rec env e1,tr_rec env e2,tr_recs env es,pos,mo,Loc_unknown,layout) | Lifused (id,e) -> Lifused (id,tr_rec env e) | Lregion e -> Lregion (tr_rec env e) | Lletrec _|Lfunction _ @@ -746,7 +748,7 @@ let shallow_iter ~tail ~non_tail:f = function f for_from; f for_to; f for_body | Lassign(_, e) -> f e - | Lsend (_k, met, obj, args, _, _, _) -> + | Lsend (_k, met, obj, args, _, _, _, _) -> List.iter f (met::obj::args) | Levent (e, _evt) -> tail e @@ -825,7 +827,7 @@ let rec free_variables = function (Ident.Set.remove for_id (free_variables for_body))) | Lassign(id, e) -> Ident.Set.add id (free_variables e) - | Lsend (_k, met, obj, args, _, _, _) -> + | Lsend (_k, met, obj, args, _, _, _, _) -> free_variables_list (Ident.Set.union (free_variables met) (free_variables obj)) args @@ -1007,9 +1009,9 @@ let subst update_env ?(freshen_bound_variables = false) s input_lam = assert (not (Ident.Map.mem id s)); let id = try Ident.Map.find id l with Not_found -> id in Lassign(id, subst s l e) - | Lsend (k, met, obj, args, pos, mode, loc) -> + | Lsend (k, met, obj, args, pos, mode, loc, layout) -> Lsend (k, subst s l met, subst s l obj, subst_list s l args, - pos, mode, loc) + pos, mode, loc, layout) | Levent (lam, evt) -> let old_env = evt.lev_env in let env_updates = @@ -1070,11 +1072,12 @@ let shallow_map ~tail ~non_tail:f = function | Lvar _ | Lmutvar _ | Lconst _ as lam -> lam - | Lapply { ap_func; ap_args; ap_region_close; ap_mode; ap_loc; ap_tailcall; + | Lapply { ap_func; ap_args; ap_result_layout; ap_region_close; ap_mode; ap_loc; ap_tailcall; ap_inlined; ap_specialised; ap_probe } -> Lapply { ap_func = f ap_func; ap_args = List.map f ap_args; + ap_result_layout; ap_region_close; ap_mode; ap_loc; @@ -1131,8 +1134,8 @@ let shallow_map ~tail ~non_tail:f = function for_body = f lf.for_body } | Lassign (v, e) -> Lassign (v, f e) - | Lsend (k, m, o, el, pos, mode, loc) -> - Lsend (k, f m, f o, List.map f el, pos, mode, loc) + | Lsend (k, m, o, el, pos, mode, loc, layout) -> + Lsend (k, f m, f o, List.map f el, pos, mode, loc, layout) | Levent (l, ev) -> Levent (tail l, ev) | Lifused (v, e) -> @@ -1329,3 +1332,5 @@ let structured_constant_layout = function | Const_base const -> constant_layout const | Const_block _ | Const_immstring _ -> Pvalue Pgenval | Const_float_array _ | Const_float_block _ -> Pvalue (Parrayval Pfloatarray) + +let primitive_result_layout (_p : primitive) = layout_top diff --git a/ocaml/lambda/lambda.mli b/ocaml/lambda/lambda.mli index 915a04a7b3e..cb853d1bbbb 100644 --- a/ocaml/lambda/lambda.mli +++ b/ocaml/lambda/lambda.mli @@ -370,7 +370,7 @@ type lambda = | Lfor of lambda_for | Lassign of Ident.t * lambda | Lsend of meth_kind * lambda * lambda * lambda list - * region_close * alloc_mode * scoped_location + * region_close * alloc_mode * scoped_location * layout | Levent of lambda * lambda_event | Lifused of Ident.t * lambda | Lregion of lambda @@ -409,6 +409,7 @@ and lambda_for = and lambda_apply = { ap_func : lambda; ap_args : lambda list; + ap_result_layout : layout; ap_region_close : region_close; ap_mode : alloc_mode; ap_loc : scoped_location; @@ -482,6 +483,8 @@ val layout_boxedint : boxed_integer -> layout val layout_field : layout val layout_lazy : layout val layout_lazy_contents : layout +(* A layout that is Pgenval because we are missing layout polymorphism *) +val layout_any_value : layout val layout_top : layout @@ -626,3 +629,5 @@ val mod_field: ?read_semantics: field_read_semantics -> int -> primitive val mod_setfield: int -> primitive val structured_constant_layout : structured_constant -> layout + +val primitive_result_layout : primitive -> layout diff --git a/ocaml/lambda/matching.ml b/ocaml/lambda/matching.ml index 9e2ee881faf..0e1d6e0c213 100644 --- a/ocaml/lambda/matching.ml +++ b/ocaml/lambda/matching.ml @@ -1929,6 +1929,7 @@ let inline_lazy_force_cond arg pos loc = ap_loc = loc; ap_func = force_fun; ap_args = [ varg ]; + ap_result_layout = Lambda.layout_lazy_contents; ap_region_close = pos; ap_mode = alloc_heap; ap_inlined = Default_inlined; @@ -1965,6 +1966,7 @@ let inline_lazy_force_switch arg pos loc = ap_loc = loc; ap_func = force_fun; ap_args = [ varg ]; + ap_result_layout = Lambda.layout_lazy_contents; ap_region_close = pos; ap_mode = alloc_heap; ap_inlined = Default_inlined; @@ -1987,6 +1989,7 @@ let inline_lazy_force arg pos loc = ap_loc = loc; ap_func = Lazy.force code_force_lazy; ap_args = [ arg ]; + ap_result_layout = Lambda.layout_lazy_contents; ap_region_close = pos; ap_mode = alloc_heap; ap_inlined = Default_inlined; diff --git a/ocaml/lambda/printlambda.ml b/ocaml/lambda/printlambda.ml index 9230ff8a97a..eb094934f68 100644 --- a/ocaml/lambda/printlambda.ml +++ b/ocaml/lambda/printlambda.ml @@ -771,7 +771,7 @@ let rec lam ppf = function lam for_to (alloc_mode mode) lam for_body | Lassign(id, expr) -> fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr - | Lsend (k, met, obj, largs, pos, reg, _) -> + | Lsend (k, met, obj, largs, pos, reg, _, _) -> let args ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in let kind = diff --git a/ocaml/lambda/simplif.ml b/ocaml/lambda/simplif.ml index fbaf43d4e17..a12c625b16b 100644 --- a/ocaml/lambda/simplif.ml +++ b/ocaml/lambda/simplif.ml @@ -88,9 +88,9 @@ let rec eliminate_ref id = function for_body = eliminate_ref id lf.for_body } | Lassign(v, e) -> Lassign(v, eliminate_ref id e) - | Lsend(k, m, o, el, pos, mode, loc) -> + | Lsend(k, m, o, el, pos, mode, loc, layout) -> Lsend(k, eliminate_ref id m, eliminate_ref id o, - List.map (eliminate_ref id) el, pos, mode, loc) + List.map (eliminate_ref id) el, pos, mode, loc, layout) | Levent(l, ev) -> Levent(eliminate_ref id l, ev) | Lifused(v, e) -> @@ -181,7 +181,7 @@ let simplify_exits lam = count ~try_depth lf.for_to; count ~try_depth lf.for_body | Lassign(_v, l) -> count ~try_depth l - | Lsend(_k, m, o, ll, _, _, _) -> List.iter (count ~try_depth) (m::o::ll) + | Lsend(_k, m, o, ll, _, _, _, _) -> List.iter (count ~try_depth) (m::o::ll) | Levent(l, _) -> count ~try_depth l | Lifused(_v, l) -> count ~try_depth l | Lregion l -> count ~try_depth l @@ -324,9 +324,9 @@ let simplify_exits lam = for_to = simplif ~try_depth lf.for_to; for_body = simplif ~try_depth lf.for_body} | Lassign(v, l) -> Lassign(v, simplif ~try_depth l) - | Lsend(k, m, o, ll, pos, mode, loc) -> + | Lsend(k, m, o, ll, pos, mode, loc, layout) -> Lsend(k, simplif ~try_depth m, simplif ~try_depth o, - List.map (simplif ~try_depth) ll, pos, mode, loc) + List.map (simplif ~try_depth) ll, pos, mode, loc, layout) | Levent(l, ev) -> Levent(simplif ~try_depth l, ev) | Lifused(v, l) -> Lifused (v,simplif ~try_depth l) | Lregion l -> Lregion (simplif ~try_depth l) @@ -458,7 +458,7 @@ let simplify_lets lam = (* Lalias-bound variables are never assigned, so don't increase v's refcount *) count bv l - | Lsend(_, m, o, ll, _, _, _) -> List.iter (count bv) (m::o::ll) + | Lsend(_, m, o, ll, _, _, _, _) -> List.iter (count bv) (m::o::ll) | Levent(l, _) -> count bv l | Lifused(v, l) -> if count_var v > 0 then count bv l @@ -608,8 +608,8 @@ let simplify_lets lam = for_to = simplif lf.for_to; for_body = simplif lf.for_body} | Lassign(v, l) -> Lassign(v, simplif l) - | Lsend(k, m, o, ll, pos, mode, loc) -> - Lsend(k, simplif m, simplif o, List.map simplif ll, pos, mode, loc) + | Lsend(k, m, o, ll, pos, mode, loc, layout) -> + Lsend(k, simplif m, simplif o, List.map simplif ll, pos, mode, loc, layout) | Levent(l, ev) -> Levent(simplif l, ev) | Lifused(v, l) -> if count_var v > 0 then simplif l else lambda_unit @@ -696,7 +696,7 @@ let rec emit_tail_infos is_tail lambda = emit_tail_infos false for_body | Lassign (_, lam) -> emit_tail_infos false lam - | Lsend (_, meth, obj, args, _, _, _loc) -> + | Lsend (_, meth, obj, args, _, _, _loc, _) -> emit_tail_infos false meth; emit_tail_infos false obj; list_emit_tail_infos false args @@ -760,6 +760,7 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body Lapply { ap_func = Lvar inner_id; ap_args = args; + ap_result_layout = return; ap_loc = Loc_unknown; ap_region_close = Rc_normal; ap_mode = alloc_heap; diff --git a/ocaml/lambda/translclass.ml b/ocaml/lambda/translclass.ml index e536939bc5a..c3434109de2 100644 --- a/ocaml/lambda/translclass.ml +++ b/ocaml/lambda/translclass.ml @@ -56,12 +56,13 @@ let lapply ap = | _ -> Lapply ap -let mkappl (func, args) = +let mkappl (func, args, layout) = Lprim (Popaque, [Lapply { ap_loc=Loc_unknown; ap_func=func; + ap_result_layout=layout; ap_args=args; ap_region_close=Rc_normal; ap_mode=alloc_heap; @@ -91,7 +92,7 @@ let set_inst_var ~scopes obj id expr = let transl_val tbl create name = mkappl (oo_prim (if create then "new_variable" else "get_variable"), - [Lvar tbl; transl_label name]) + [Lvar tbl; transl_label name], Lambda.layout_int) let transl_vals tbl create strict vals rem = List.fold_right @@ -104,7 +105,7 @@ let meths_super tbl meths inh_meths = (fun (nm, id) rem -> try (nm, id, - mkappl(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)])) + mkappl(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)], Lambda.layout_function)) :: rem with Not_found -> rem) inh_meths [] @@ -122,15 +123,15 @@ let create_object cl obj init = (inh_init, mkappl (oo_prim (if has_init then "create_object_and_run_initializers" else"create_object_opt"), - [obj; Lvar cl])) + [obj; Lvar cl], Lambda.layout_object)) else begin (inh_init, Llet(Strict, Lambda.layout_object, obj', - mkappl (oo_prim "create_object_opt", [obj; Lvar cl]), + mkappl (oo_prim "create_object_opt", [obj; Lvar cl], Lambda.layout_object), Lsequence(obj_init, if not has_init then Lvar obj' else mkappl (oo_prim "run_initializers_opt", - [obj; Lvar obj'; Lvar cl])))) + [obj; Lvar obj'; Lvar cl], Lambda.layout_object)))) end let name_pattern default p = @@ -154,7 +155,7 @@ let rec build_object_init ~scopes cl_table obj params inh_init obj_init cl = let loc = of_location ~scopes cl.cl_loc in let path_lam = transl_class_path loc cl.cl_env path in ((envs, (path, path_lam, obj_init) :: inh_init), - mkappl(Lvar obj_init, env @ [obj])) + mkappl(Lvar obj_init, env @ [obj], Lambda.layout_object)) | Tcl_structure str -> create_object cl_table obj (fun obj -> let (inh_init, obj_init, has_init) = @@ -244,7 +245,7 @@ let rec build_object_init_0 let bind_method tbl lab id cl_init = Llet(Strict, Lambda.layout_int, id, mkappl (oo_prim "get_method_label", - [Lvar tbl; transl_label lab]), + [Lvar tbl; transl_label lab], Lambda.layout_int), cl_init) let bind_methods tbl meths vals cl_init = @@ -260,7 +261,8 @@ let bind_methods tbl meths vals cl_init = in Llet(Strict, Lambda.layout_array Pintarray, ids, mkappl (oo_prim getter, - [Lvar tbl; transl_meth_list (List.map fst methl)] @ names), + [Lvar tbl; transl_meth_list (List.map fst methl)] @ names, + Lambda.layout_array Pintarray), List.fold_right (fun (_lab,id) lam -> decr i; Llet(StrictOpt, Lambda.layout_int, id, lfield ids !i, lam)) @@ -270,13 +272,13 @@ let output_methods tbl methods lam = match methods with [] -> lam | [lab; code] -> - lsequence (mkappl(oo_prim "set_method", [Lvar tbl; lab; code])) lam + lsequence (mkappl(oo_prim "set_method", [Lvar tbl; lab; code], Lambda.layout_unit)) lam | _ -> let methods = Lprim(Pmakeblock(0,Immutable,None,alloc_heap), methods, Loc_unknown) in lsequence (mkappl(oo_prim "set_methods", - [Lvar tbl; Lprim (Popaque, [methods], Loc_unknown)])) + [Lvar tbl; Lprim (Popaque, [methods], Loc_unknown)], Lambda.layout_unit)) lam let rec ignore_cstrs cl = @@ -301,9 +303,9 @@ let rec build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl = | (_, path_lam, obj_init)::inh_init -> (inh_init, Llet (Strict, Lambda.layout_object, obj_init, - mkappl(Lprim(class_field 1, [path_lam], Loc_unknown), Lvar cla :: + mkappl(Lprim(class_field 1, [path_lam], Loc_unknown), (Lvar cla :: if top then [Lprim(class_field 3, [path_lam], Loc_unknown)] - else []), + else []), Lambda.layout_object), bind_super cla super cl_init)) | _ -> assert false @@ -348,7 +350,7 @@ let rec build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl = (inh_init, Lsequence(mkappl (oo_prim "add_initializer", Lvar cla :: msubst false - (transl_exp ~scopes exp)), + (transl_exp ~scopes exp), Lambda.layout_unit), cl_init), methods, values) | Tcf_attribute _ -> @@ -405,7 +407,8 @@ let rec build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl = Llet (Strict, Lambda.layout_array Pgenarray, inh, mkappl(oo_prim "inherits", narrow_args @ [path_lam; - Lconst(const_int (if top then 1 else 0))]), + Lconst(const_int (if top then 1 else 0))], + Lambda.layout_array Pgenarray), Llet(StrictOpt, Lambda.layout_top, obj_init, lfield inh 0, cl_init))) | _ -> let core cl_init = @@ -414,10 +417,10 @@ let rec build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl = in if cstr then core cl_init else let (inh_init, cl_init) = - core (Lsequence (mkappl (oo_prim "widen", [Lvar cla]), cl_init)) + core (Lsequence (mkappl (oo_prim "widen", [Lvar cla], Lambda.layout_unit), cl_init)) in (inh_init, - Lsequence(mkappl (oo_prim "narrow", narrow_args), + Lsequence(mkappl (oo_prim "narrow", narrow_args, Lambda.layout_unit), cl_init)) end | Tcl_open (_, cl) -> @@ -522,6 +525,7 @@ let transl_class_rebind ~scopes cl vf = ap_loc=Loc_unknown; ap_func=Lvar obj_init; ap_args=[Lvar self]; + ap_result_layout=Lambda.layout_object; ap_region_close=Rc_normal; ap_mode=alloc_heap; ap_tailcall=Default_tailcall; @@ -545,13 +549,13 @@ let transl_class_rebind ~scopes cl vf = Llet( Alias, Lambda.layout_class, cla, path_lam, Lprim(Pmakeblock(0, Immutable, None, alloc_heap), - [mkappl(Lvar new_init, [lfield cla 0]); + [mkappl(Lvar new_init, [lfield cla 0], Lambda.layout_object); lfunction Lambda.layout_top [table, Lambda.layout_top] (Llet(Strict, Lambda.layout_top, env_init, - mkappl(lfield cla 1, [Lvar table]), + mkappl(lfield cla 1, [Lvar table], Lambda.layout_top), lfunction Lambda.layout_top [envs, Lambda.layout_top] (mkappl(Lvar new_init, - [mkappl(Lvar env_init, [Lvar envs])])))); + [mkappl(Lvar env_init, [Lvar envs], Lambda.layout_top)], Lambda.layout_top)))); lfield cla 2; lfield cla 3], Loc_unknown))) @@ -577,7 +581,7 @@ let rec builtin_meths self env env2 body = "var", [Lvar n] | Lprim(Pfield (n, _), [Lvar e], _) when Ident.same e env -> "env", [Lvar env2; Lconst(const_int n)] - | Lsend(Self, met, Lvar s, [], _, _, _) when List.mem s self -> + | Lsend(Self, met, Lvar s, [], _, _, _, _) when List.mem s self -> "meth", [met] | _ -> raise Not_found in @@ -592,15 +596,15 @@ let rec builtin_meths self env env2 body = | Lapply{ap_func = f; ap_args = [p; arg]} when const_path f && const_path p -> let s, args = conv arg in ("app_const_"^s, f :: p :: args) - | Lsend(Self, Lvar n, Lvar s, [arg], _, _, _) when List.mem s self -> + | Lsend(Self, Lvar n, Lvar s, [arg], _, _, _, _) when List.mem s self -> let s, args = conv arg in ("meth_app_"^s, Lvar n :: args) - | Lsend(Self, met, Lvar s, [], _, _, _) when List.mem s self -> + | Lsend(Self, met, Lvar s, [], _, _, _, _) when List.mem s self -> ("get_meth", [met]) - | Lsend(Public, met, arg, [], _, _, _) -> + | Lsend(Public, met, arg, [], _, _, _, _) -> let s, args = conv arg in ("send_"^s, met :: args) - | Lsend(Cached, met, arg, [_;_], _, _, _) -> + | Lsend(Cached, met, arg, [_;_], _, _, _, _) -> let s, args = conv arg in ("send_"^s, met :: args) | Lfunction {kind = Curried _; params = [x, _]; body} -> @@ -682,7 +686,7 @@ let free_methods l = let rec free l = Lambda.iter_head_constructor free l; match l with - | Lsend(Self, Lvar meth, _, _, _, _, _) -> + | Lsend(Self, Lvar meth, _, _, _, _, _, _) -> fv := Ident.Set.add meth !fv | Lsend _ -> () | Lfunction{params} -> @@ -809,11 +813,12 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = tags pub_meths; let ltable table lam = Llet(Strict, Lambda.layout_array Pgenarray, table, - mkappl (oo_prim "create_table", [transl_meth_list pub_meths]), lam) + mkappl (oo_prim "create_table", [transl_meth_list pub_meths], + Lambda.layout_array Pgenarray), lam) and ldirect obj_init = Llet(Strict, Lambda.layout_top, obj_init, cl_init, - Lsequence(mkappl (oo_prim "init_class", [Lvar cla]), - mkappl (Lvar obj_init, [lambda_unit]))) + Lsequence(mkappl (oo_prim "init_class", [Lvar cla], Lambda.layout_unit), + mkappl (Lvar obj_init, [lambda_unit], Lambda.layout_top))) in (* Simplest case: an object defined at toplevel (ids=[]) *) if top && ids = [] then llets (ltable cla (ldirect obj_init)) else @@ -832,15 +837,15 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = and lbody fv = if List.for_all (fun id -> not (Ident.Set.mem id fv)) ids then mkappl (oo_prim "make_class",[transl_meth_list pub_meths; - Lvar class_init]) + Lvar class_init], Lambda.layout_class) else ltable table ( Llet( - Strict, Lambda.layout_top, env_init, mkappl (Lvar class_init, [Lvar table]), + Strict, Lambda.layout_top, env_init, mkappl (Lvar class_init, [Lvar table], Lambda.layout_top), Lsequence( - mkappl (oo_prim "init_class", [Lvar table]), + mkappl (oo_prim "init_class", [Lvar table], Lambda.layout_top), Lprim(Pmakeblock(0, Immutable, None, alloc_heap), - [mkappl (Lvar env_init, [lambda_unit]); + [mkappl (Lvar env_init, [lambda_unit], Lambda.layout_top); Lvar class_init; Lvar env_init; lambda_unit], Loc_unknown)))) and lbody_virt lenvs = @@ -890,7 +895,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = lam) and def_ids cla lam = Llet(StrictOpt, Lambda.layout_int, env2, - mkappl (oo_prim "new_variable", [Lvar cla; transl_label ""]), + mkappl (oo_prim "new_variable", [Lvar cla; transl_label ""], Lambda.layout_int), lam) in let inh_paths = @@ -918,7 +923,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = Llet(Strict, Lambda.layout_top, cached, mkappl (oo_prim "lookup_tables", [Lvar tables; Lprim(Pmakearray(Paddrarray, Immutable, alloc_heap), - inh_keys, Loc_unknown)]), + inh_keys, Loc_unknown)], Lambda.layout_top), lam) and lset cached i lam = Lprim(Psetfield(i, Pointer, Assignment alloc_heap), @@ -927,7 +932,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = let ldirect () = ltable cla (Llet(Strict, Lambda.layout_top, env_init, def_ids cla cl_init, - Lsequence(mkappl (oo_prim "init_class", [Lvar cla]), + Lsequence(mkappl (oo_prim "init_class", [Lvar cla], Lambda.layout_unit), lset cached 0 (Lvar env_init)))) and lclass_virt () = lset cached 0 @@ -947,7 +952,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = lclass ( mkappl (oo_prim "make_class_store", [transl_meth_list pub_meths; - Lvar class_init; Lvar cached])) in + Lvar class_init; Lvar cached], Lambda.layout_top)) in let lcheck_cache = if !Clflags.native_code && !Clflags.afl_instrument then (* When afl-fuzz instrumentation is enabled, ignore the cache @@ -959,10 +964,10 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = lcache ( Lsequence(lcheck_cache, make_envs ( - if ids = [] then mkappl (lfield cached 0, [lenvs]) else + if ids = [] then mkappl (lfield cached 0, [lenvs], Lambda.layout_top) else Lprim(Pmakeblock(0, Immutable, None, alloc_heap), (if concrete then - [mkappl (lfield cached 0, [lenvs]); + [mkappl (lfield cached 0, [lenvs], Lambda.layout_top); lfield cached 1; lfield cached 0; lenvs] diff --git a/ocaml/lambda/translcomprehension.ml b/ocaml/lambda/translcomprehension.ml index 5c760ecabad..88e1a0006b9 100644 --- a/ocaml/lambda/translcomprehension.ml +++ b/ocaml/lambda/translcomprehension.ml @@ -506,6 +506,7 @@ let transl_list_comp type_comp body acc_var mats ~transl_exp ~scopes ~loc = ap_mode=alloc_heap; ap_func=func; ap_args= fn::args; + ap_result_layout = Lambda.layout_list; ap_tailcall=Default_tailcall; ap_inlined=Default_inlined; ap_specialised=Default_specialise; @@ -546,6 +547,7 @@ let transl_list_comprehension ~transl_exp ~loc ~scopes body blocks = ap_loc=loc; ap_func=comp_rev (); ap_args=[res_list]; + ap_result_layout = Lambda.layout_list; ap_region_close=Rc_normal; ap_mode=alloc_heap; ap_tailcall=Default_tailcall; diff --git a/ocaml/lambda/translcore.ml b/ocaml/lambda/translcore.ml index 5a16b9618b5..4b21f996e42 100644 --- a/ocaml/lambda/translcore.ml +++ b/ocaml/lambda/translcore.ml @@ -118,7 +118,7 @@ let may_allocate_in_region lam = | Lfunction {mode=Alloc_local} -> raise Exit | Lapply {ap_mode=Alloc_local} - | Lsend (_,_,_,_,_,Alloc_local,_) -> raise Exit + | Lsend (_,_,_,_,_,Alloc_local,_,_) -> raise Exit | Lprim (prim, args, _) -> begin match Lambda.primitive_may_allocate prim with @@ -151,8 +151,8 @@ let maybe_region lam = let rec remove_tail_markers = function | Lapply ({ap_region_close = Rc_close_at_apply} as ap) -> Lapply ({ap with ap_region_close = Rc_normal}) - | Lsend (k, lmet, lobj, largs, Rc_close_at_apply, mode, loc) -> - Lsend (k, lmet, lobj, largs, Rc_normal, mode, loc) + | Lsend (k, lmet, lobj, largs, Rc_close_at_apply, mode, loc, layout) -> + Lsend (k, lmet, lobj, largs, Rc_normal, mode, loc, layout) | Lregion _ as lam -> lam | lam -> Lambda.shallow_map ~tail:remove_tail_markers ~non_tail:Fun.id lam @@ -621,20 +621,22 @@ and transl_exp0 ~in_new_scope ~scopes e = let pos = transl_apply_position pos in let mode = transl_exp_mode e in let loc = of_location ~scopes e.exp_loc in + let layout = Typeopt.layout e.exp_env e.exp_type in match met with | Tmeth_val id -> let obj = transl_exp ~scopes expr in - Lsend (Self, Lvar id, obj, [], pos, mode, loc) + Lsend (Self, Lvar id, obj, [], pos, mode, loc, layout) | Tmeth_name nm -> let obj = transl_exp ~scopes expr in let (tag, cache) = Translobj.meth obj nm in let kind = if cache = [] then Public else Cached in - Lsend (kind, tag, obj, cache, pos, mode, loc) + Lsend (kind, tag, obj, cache, pos, mode, loc, layout) | Tmeth_ancestor(meth, path_self) -> let self = transl_value_path loc e.exp_env path_self in Lapply {ap_loc = loc; ap_func = Lvar meth; ap_args = [self]; + ap_result_layout = layout; ap_mode = mode; ap_region_close = pos; ap_probe = None; @@ -652,6 +654,7 @@ and transl_exp0 ~in_new_scope ~scopes e = Lprim(Pfield (0, Reads_vary), [transl_class_path loc e.exp_env cl], loc); ap_args=[lambda_unit]; + ap_result_layout=Typeopt.layout e.exp_env e.exp_type; ap_region_close=pos; ap_mode=alloc_heap; ap_tailcall=Default_tailcall; @@ -678,6 +681,7 @@ and transl_exp0 ~in_new_scope ~scopes e = ap_loc=Loc_unknown; ap_func=Translobj.oo_prim "copy"; ap_args=[self]; + ap_result_layout=Lambda.layout_object; ap_region_close=Rc_normal; ap_mode=alloc_heap; ap_tailcall=Default_tailcall; @@ -849,6 +853,7 @@ and transl_exp0 ~in_new_scope ~scopes e = let app = { ap_func = Lvar funcid; ap_args = List.map (fun id -> Lvar id) arg_idents; + ap_result_layout = Typeopt.layout exp.exp_env exp.exp_type; ap_region_close = Rc_normal; ap_mode = alloc_heap; ap_loc = of_location e.exp_loc ~scopes; @@ -940,24 +945,25 @@ and transl_apply ~scopes lam sargs loc = let lapply funct args loc pos mode = + let result_layout = Lambda.layout_top in match funct, pos with - | Lsend((Self | Public) as k, lmet, lobj, [], _, _, _), _ -> - Lsend(k, lmet, lobj, args, pos, mode, loc) - | Lsend(Cached, lmet, lobj, ([_; _] as largs), _, _, _), _ -> - Lsend(Cached, lmet, lobj, largs @ args, pos, mode, loc) - | Lsend(k, lmet, lobj, largs, (Rc_normal | Rc_nontail), _, _), + | Lsend((Self | Public) as k, lmet, lobj, [], _, _, _, _), _ -> + Lsend(k, lmet, lobj, args, pos, mode, loc, result_layout) + | Lsend(Cached, lmet, lobj, ([_; _] as largs), _, _, _, _), _ -> + Lsend(Cached, lmet, lobj, largs @ args, pos, mode, loc, result_layout) + | Lsend(k, lmet, lobj, largs, (Rc_normal | Rc_nontail), _, _, _), (Rc_normal | Rc_nontail) -> - Lsend(k, lmet, lobj, largs @ args, pos, mode, loc) + Lsend(k, lmet, lobj, largs @ args, pos, mode, loc, result_layout) | Levent( - Lsend((Self | Public) as k, lmet, lobj, [], _, _, _), _), _ -> - Lsend(k, lmet, lobj, args, pos, mode, loc) + Lsend((Self | Public) as k, lmet, lobj, [], _, _, _, _), _), _ -> + Lsend(k, lmet, lobj, args, pos, mode, loc, result_layout) | Levent( - Lsend(Cached, lmet, lobj, ([_; _] as largs), _, _, _), _), _ -> - Lsend(Cached, lmet, lobj, largs @ args, pos, mode, loc) + Lsend(Cached, lmet, lobj, ([_; _] as largs), _, _, _, _), _), _ -> + Lsend(Cached, lmet, lobj, largs @ args, pos, mode, loc, result_layout) | Levent( - Lsend(k, lmet, lobj, largs, (Rc_normal | Rc_nontail), _, _), _), + Lsend(k, lmet, lobj, largs, (Rc_normal | Rc_nontail), _, _, _), _), (Rc_normal | Rc_nontail) -> - Lsend(k, lmet, lobj, largs @ args, pos, mode, loc) + Lsend(k, lmet, lobj, largs @ args, pos, mode, loc, result_layout) | Lapply ({ ap_region_close = (Rc_normal | Rc_nontail) } as ap), (Rc_normal | Rc_nontail) -> Lapply @@ -968,6 +974,7 @@ and transl_apply ~scopes ap_loc=loc; ap_func=lexp; ap_args=args; + ap_result_layout=result_layout; ap_region_close=pos; ap_mode=mode; ap_tailcall=tailcall; @@ -1505,6 +1512,7 @@ and transl_letop ~scopes loc env let_ ands param case partial warnings = ap_loc = of_location ~scopes and_.bop_loc; ap_func = op; ap_args=[Lvar left_id; Lvar right_id]; + ap_result_layout = layout; ap_region_close=Rc_normal; ap_mode=alloc_heap; ap_tailcall = Default_tailcall; @@ -1539,6 +1547,7 @@ and transl_letop ~scopes loc env let_ ands param case partial warnings = ap_loc = of_location ~scopes loc; ap_func = op; ap_args=[exp; func]; + ap_result_layout=Lambda.layout_top; ap_region_close=Rc_normal; ap_mode=alloc_heap; ap_tailcall = Default_tailcall; diff --git a/ocaml/lambda/translmod.ml b/ocaml/lambda/translmod.ml index e61ce7a67ed..fc232b33c83 100644 --- a/ocaml/lambda/translmod.ml +++ b/ocaml/lambda/translmod.ml @@ -146,6 +146,7 @@ and apply_coercion_result loc strict funct params args cc_res = ap_loc=loc; ap_func=Lvar id; ap_args=List.rev args; + ap_result_layout=Lambda.layout_module; ap_region_close=Rc_normal; ap_mode=alloc_heap; ap_tailcall=Default_tailcall; @@ -410,6 +411,7 @@ let eval_rec_bindings bindings cont = Lapply{ ap_loc=Loc_unknown; ap_func=mod_prim "init_mod"; + ap_result_layout = Lambda.layout_module; ap_args=[loc; shape]; ap_region_close=Rc_normal; ap_mode=alloc_heap; @@ -439,6 +441,7 @@ let eval_rec_bindings bindings cont = Lapply { ap_loc=Loc_unknown; ap_func=mod_prim "update_mod"; + ap_result_layout = Lambda.layout_unit; ap_args=[shape; Lvar id; rhs]; ap_region_close=Rc_normal; ap_mode=alloc_heap; @@ -581,6 +584,7 @@ and transl_module ~scopes cc rootpath mexp = ap_loc=loc; ap_func=transl_module ~scopes Tcoerce_none None funct; ap_args=[transl_module ~scopes ccarg None arg]; + ap_result_layout = Lambda.layout_module; ap_region_close=Rc_normal; ap_mode=alloc_heap; ap_tailcall=Default_tailcall; @@ -858,6 +862,7 @@ and transl_include_functor ~generative modl params scopes loc = ap_loc = loc; ap_func = modl; ap_args = params; + ap_result_layout = Lambda.layout_module; ap_region_close=Rc_normal; ap_mode = alloc_heap; ap_tailcall = Default_tailcall; @@ -1554,6 +1559,7 @@ let toploop_getvalue id = Loc_unknown); ap_args=[Lconst(Const_base( Const_string (toplevel_name id, Location.none, None)))]; + ap_result_layout = Lambda.layout_top; ap_region_close=Rc_normal; ap_mode=alloc_heap; ap_tailcall=Default_tailcall; @@ -1572,6 +1578,7 @@ let toploop_setvalue id lam = [Lconst(Const_base( Const_string(toplevel_name id, Location.none, None))); lam]; + ap_result_layout = Lambda.layout_top; ap_region_close=Rc_normal; ap_mode=alloc_heap; ap_tailcall=Default_tailcall; diff --git a/ocaml/lambda/translprim.ml b/ocaml/lambda/translprim.ml index f7be1d231ee..287b8b7b6e6 100644 --- a/ocaml/lambda/translprim.ml +++ b/ocaml/lambda/translprim.ml @@ -90,8 +90,8 @@ type prim = | Send_cache of Lambda.region_close | Frame_pointers | Identity - | Apply of Lambda.region_close - | Revapply of Lambda.region_close + | Apply of Lambda.region_close * Lambda.layout + | Revapply of Lambda.region_close * Lambda.layout let units_with_used_primitives = Hashtbl.create 7 let add_used_primitive loc env path = @@ -132,8 +132,8 @@ let lookup_primitive loc poly pos p = | "%bytes_to_string" -> Primitive (Pbytes_to_string, 1) | "%bytes_of_string" -> Primitive (Pbytes_of_string, 1) | "%ignore" -> Primitive (Pignore, 1) - | "%revapply" -> Revapply pos - | "%apply" -> Apply pos + | "%revapply" -> Revapply (pos, Lambda.layout_any_value) + | "%apply" -> Apply (pos, Lambda.layout_any_value) | "%loc_LOC" -> Loc Loc_LOC | "%loc_FILE" -> Loc Loc_FILE | "%loc_LINE" -> Loc Loc_LINE @@ -719,26 +719,27 @@ let lambda_of_prim prim_name prim loc args arg_exps = let lam = lambda_of_loc kind loc in Lprim(Pmakeblock(0, Immutable, None, alloc_heap), [lam; arg], loc) | Send pos, [obj; meth] -> - Lsend(Public, meth, obj, [], pos, alloc_heap, loc) + Lsend(Public, meth, obj, [], pos, alloc_heap, loc, Lambda.layout_top) | Send_self pos, [obj; meth] -> - Lsend(Self, meth, obj, [], pos, alloc_heap, loc) + Lsend(Self, meth, obj, [], pos, alloc_heap, loc, Lambda.layout_top) | Send_cache apos, [obj; meth; cache; pos] -> (* Cached mode only works in the native backend *) if !Clflags.native_code then - Lsend(Cached, meth, obj, [cache; pos], apos, alloc_heap, loc) + Lsend(Cached, meth, obj, [cache; pos], apos, alloc_heap, loc, Lambda.layout_top) else - Lsend(Public, meth, obj, [], apos, alloc_heap, loc) + Lsend(Public, meth, obj, [], apos, alloc_heap, loc, Lambda.layout_top) | Frame_pointers, [] -> let frame_pointers = if !Clflags.native_code && Config.with_frame_pointers then 1 else 0 in Lconst (const_int frame_pointers) | Identity, [arg] -> arg - | Apply pos, [func; arg] - | Revapply pos, [arg; func] -> + | Apply (pos, layout), [func; arg] + | Revapply (pos, layout), [arg; func] -> Lapply { ap_func = func; ap_args = [arg]; + ap_result_layout = layout; ap_loc = loc; (* CR-someday lwhite: it would be nice to be able to give application attributes to functions applied with the application diff --git a/ocaml/middle_end/closure/closure.ml b/ocaml/middle_end/closure/closure.ml index b4cc9d588b0..b3ab903cf56 100644 --- a/ocaml/middle_end/closure/closure.ml +++ b/ocaml/middle_end/closure/closure.ml @@ -1104,6 +1104,7 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) ap_loc=loc; ap_func=(Lvar funct_var); ap_args=internal_args; + ap_result_layout=Lambda.layout_top; ap_region_close=Rc_normal; ap_mode=ret_mode; ap_tailcall=Default_tailcall; @@ -1170,7 +1171,7 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) fail_if_probe ~probe "Unknown function"; (Ugeneric_apply(ufunct, uargs, (pos, mode), dbg), Value_unknown) end - | Lsend(kind, met, obj, args, pos, mode, loc) -> + | Lsend(kind, met, obj, args, pos, mode, loc, _result_layout) -> let (umet, _) = close env met in let (uobj, _) = close env obj in let dbg = Debuginfo.from_location loc in diff --git a/ocaml/middle_end/flambda/closure_conversion.ml b/ocaml/middle_end/flambda/closure_conversion.ml index d256d9e1576..b2de54de60a 100644 --- a/ocaml/middle_end/flambda/closure_conversion.ml +++ b/ocaml/middle_end/flambda/closure_conversion.ml @@ -324,7 +324,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = in Let_rec (defs, close t env body) end - | Lsend (kind, meth, obj, args, reg_close, mode, loc) -> + | Lsend (kind, meth, obj, args, reg_close, mode, loc, _layout) -> let meth_var = Variable.create Names.meth in let obj_var = Variable.create Names.obj in let dbg = Debuginfo.from_location loc in