From 7ce5ef4095c5caf6403364d628175a2cd4a60f2b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nathana=C3=ABlle=20Courant?= Date: Wed, 15 Feb 2023 10:27:12 +0100 Subject: [PATCH] Changes to arity in clambda (#1106) --- backend/cmm_helpers.ml | 50 +++++---- backend/cmm_helpers.mli | 8 +- backend/cmmgen.ml | 39 ++++--- middle_end/clambda.ml | 15 ++- middle_end/clambda.mli | 15 ++- middle_end/closure/closure.ml | 102 ++++++++++------- middle_end/flambda/flambda_to_clambda.ml | 25 +++-- middle_end/flambda/un_anf.ml | 64 ++++++----- .../flambda2/to_cmm/to_cmm_set_of_closures.ml | 3 +- middle_end/printclambda.ml | 40 ++++--- ocaml/asmcomp/cmm_helpers.ml | 52 +++++---- ocaml/asmcomp/cmm_helpers.mli | 13 ++- ocaml/asmcomp/cmmgen.ml | 39 ++++--- ocaml/middle_end/clambda.ml | 15 ++- ocaml/middle_end/clambda.mli | 15 ++- ocaml/middle_end/closure/closure.ml | 104 ++++++++++-------- .../middle_end/flambda/flambda_to_clambda.ml | 25 +++-- ocaml/middle_end/flambda/un_anf.ml | 64 ++++++----- ocaml/middle_end/printclambda.ml | 39 ++++--- 19 files changed, 440 insertions(+), 287 deletions(-) diff --git a/backend/cmm_helpers.ml b/backend/cmm_helpers.ml index 0631ff00e62..62521f20f6b 100644 --- a/backend/cmm_helpers.ml +++ b/backend/cmm_helpers.ml @@ -114,10 +114,7 @@ let caml_int64_ops = "caml_int64_ops" let pos_arity_in_closinfo = (8 * size_addr) - 8 (* arity = the top 8 bits of the closinfo word *) -let closure_info ~arity ~startenv ~is_last = - let arity = - match arity with Lambda.Tupled, n -> -n | Lambda.Curried _, n -> n - in +let pack_closure_info ~arity ~startenv ~is_last = assert (-128 <= arity && arity <= 127); assert (0 <= startenv && startenv < 1 lsl (pos_arity_in_closinfo - 2)); Nativeint.( @@ -129,6 +126,19 @@ let closure_info ~arity ~startenv ~is_last = (pos_arity_in_closinfo - 1)) (add (shift_left (of_int startenv) 1) 1n))) +let closure_info' ~arity ~startenv ~is_last = + let arity = + match arity with + | Lambda.Tupled, l -> -List.length l + | Lambda.Curried _, l -> List.length l + in + pack_closure_info ~arity ~startenv ~is_last + +let closure_info ~(arity : Clambda.arity) ~startenv ~is_last = + closure_info' + ~arity:(arity.function_kind, arity.params_layout) + ~startenv ~is_last + let alloc_float_header mode dbg = match mode with | Lambda.Alloc_heap -> Cconst_natint (float_header, dbg) @@ -2684,7 +2694,6 @@ let intermediate_curry_functions ~nlocal ~arity result = let mode : Lambda.alloc_mode = if num >= narity - nlocal then Lambda.alloc_local else Lambda.alloc_heap in - let curried n = Lambda.Curried { nlocal = min nlocal n }, n in let has_nary = curry_clos_has_nary_application ~narity (num + 1) in let function_slot_size = if has_nary then 3 else 2 in Cfunction @@ -2697,11 +2706,14 @@ let intermediate_curry_functions ~nlocal ~arity result = (function_slot_size + machtype_stored_size arg_type + 1) (dbg ()); Cconst_symbol (name1 ^ "_" ^ Int.to_string (num + 1), dbg ()); - alloc_closure_info - ~arity:(curried (if has_nary then narity - num - 1 else 1)) - ~startenv: - (function_slot_size + machtype_non_scanned_size arg_type) - (dbg ()) ~is_last:true ] + Cconst_natint + ( pack_closure_info + ~arity:(if has_nary then narity - num - 1 else 1) + ~startenv: + (function_slot_size + + machtype_non_scanned_size arg_type) + ~is_last:true, + dbg () ) ] @ (if has_nary then [ Cconst_symbol @@ -3520,7 +3532,7 @@ let fundecls_size fundecls = (fun (f : Clambda.ufunction) -> let indirect_call_code_pointer_size = match f.arity with - | Curried _, (0 | 1) -> + | { function_kind = Curried _; params_layout = [] | [_]; _ } -> 0 (* arity 1 does not need an indirect call handler. arity 0 cannot be indirect called *) @@ -3557,7 +3569,7 @@ let emit_constant_closure ((_, global_symb) as symb) fundecls clos_vars cont = | (f2 : Clambda.ufunction) :: rem -> ( let is_last = match rem with [] -> true | _ :: _ -> false in match f2.arity with - | (Curried _, (0 | 1)) as arity -> + | { function_kind = Curried _; params_layout = [] | [_]; _ } as arity -> (Cint (infix_header pos) :: closure_symbol f2) @ Csymbol_address f2.label :: Cint (closure_info ~arity ~startenv:(startenv - pos) ~is_last) @@ -3565,9 +3577,9 @@ let emit_constant_closure ((_, global_symb) as symb) fundecls clos_vars cont = | arity -> (Cint (infix_header pos) :: closure_symbol f2) @ Csymbol_address - (curry_function_sym (fst arity) - (List.init (snd arity) (fun _ -> typ_val)) - typ_val) + (curry_function_sym arity.function_kind + (List.map machtype_of_layout arity.params_layout) + (machtype_of_layout arity.return_layout)) :: Cint (closure_info ~arity ~startenv:(startenv - pos) ~is_last) :: Csymbol_address f2.label :: emit_others (pos + 4) rem) @@ -3578,15 +3590,15 @@ let emit_constant_closure ((_, global_symb) as symb) fundecls clos_vars cont = @ closure_symbol f1 @ match f1.arity with - | (Curried _, (0 | 1)) as arity -> + | { function_kind = Curried _; params_layout = [] | [_]; _ } as arity -> Csymbol_address f1.label :: Cint (closure_info ~arity ~startenv ~is_last) :: emit_others 3 remainder | arity -> Csymbol_address - (curry_function_sym (fst arity) - (List.init (snd arity) (fun _ -> typ_val)) - typ_val) + (curry_function_sym arity.function_kind + (List.map machtype_of_layout arity.params_layout) + (machtype_of_layout arity.return_layout)) :: Cint (closure_info ~arity ~startenv ~is_last) :: Csymbol_address f1.label :: emit_others 4 remainder) diff --git a/backend/cmm_helpers.mli b/backend/cmm_helpers.mli index b62eea5ab97..e69c1a57026 100644 --- a/backend/cmm_helpers.mli +++ b/backend/cmm_helpers.mli @@ -63,11 +63,17 @@ val boxedintnat_header : nativeint val closure_info : arity:Clambda.arity -> startenv:int -> is_last:bool -> nativeint +val closure_info' : + arity:Lambda.function_kind * 'a list -> + startenv:int -> + is_last:bool -> + nativeint + (** Wrappers *) val alloc_infix_header : int -> Debuginfo.t -> expression val alloc_closure_info : - arity:Lambda.function_kind * int -> + arity:Clambda.arity -> startenv:int -> is_last:bool -> Debuginfo.t -> diff --git a/backend/cmmgen.ml b/backend/cmmgen.ml index 843dc83fb76..024029cff8f 100644 --- a/backend/cmmgen.ml +++ b/backend/cmmgen.ml @@ -459,15 +459,18 @@ let rec transl env e = let dbg = f.dbg in let without_header = match f.arity with - | Curried _, (1|0) as arity -> + | { function_kind = Curried _ ; params_layout = ([] | [_]) } as arity -> Cconst_symbol (f.label, dbg) :: alloc_closure_info ~arity ~startenv:(startenv - pos) ~is_last dbg :: transl_fundecls (pos + 3) rem | arity -> - Cconst_symbol ( - curry_function_sym (fst arity) - (List.init (snd arity) (fun _ -> typ_val)) typ_val, dbg) :: + Cconst_symbol + (curry_function_sym + arity.function_kind + (List.map machtype_of_layout arity.params_layout) + (machtype_of_layout arity.return_layout), + dbg) :: alloc_closure_info ~arity ~startenv:(startenv - pos) ~is_last dbg :: Cconst_symbol (f.label, dbg) :: @@ -488,26 +491,25 @@ let rec transl env e = let ptr = transl env arg in let dbg = Debuginfo.none in ptr_offset ptr offset dbg - | Udirect_apply(handler_code_sym, args, Some { name; }, _, dbg) -> + | Udirect_apply(handler_code_sym, args, Some { name; }, _, _, dbg) -> let args = List.map (transl env) args in return_unit dbg (Cop(Cprobe { name; handler_code_sym; }, args, dbg)) - | Udirect_apply(lbl, args, None, kind, dbg) -> + | Udirect_apply(lbl, args, None, result_layout, kind, dbg) -> let args = List.map (transl env) args in - let return = typ_val in - direct_apply lbl return args kind dbg - | Ugeneric_apply(clos, args, kind, dbg) -> + direct_apply lbl (machtype_of_layout result_layout) args kind dbg + | Ugeneric_apply(clos, args, args_layout, result_layout, kind, dbg) -> let clos = transl env clos in let args = List.map (transl env) args in - let args_type = List.map (fun _ -> typ_val) args in - let return = typ_val in + let args_type = List.map machtype_of_layout args_layout in + let return = machtype_of_layout result_layout in generic_apply (mut_from_env env clos) clos args args_type return kind dbg - | Usend(kind, met, obj, args, pos, dbg) -> + | Usend(kind, met, obj, args, args_layout, result_layout, pos, dbg) -> let met = transl env met in let obj = transl env obj in let args = List.map (transl env) args in - let args_type = List.map (fun _ -> typ_val) args in - let return = typ_val in + let args_type = List.map machtype_of_layout args_layout in + let return = machtype_of_layout result_layout in send kind met obj args args_type return pos dbg | Ulet(str, kind, id, exp, body) -> transl_let env str kind id exp (fun env -> transl env body) @@ -1487,8 +1489,15 @@ let transl_function f = else [ Reduce_code_size ] in + let params_layout = + if List.length f.params = List.length f.arity.params_layout then + f.arity.params_layout + else + f.arity.params_layout @ [Lambda.layout_function] + in Cfunction {fun_name = f.label; - fun_args = List.map (fun (id, _) -> (id, typ_val)) f.params; + fun_args = List.map2 (fun id ty -> (id, machtype_of_layout ty)) + f.params params_layout; fun_body = cmm_body; fun_codegen_options; fun_poll = f.poll; diff --git a/middle_end/clambda.ml b/middle_end/clambda.ml index 9aaf23f1775..ec4cba2eb15 100644 --- a/middle_end/clambda.ml +++ b/middle_end/clambda.ml @@ -20,7 +20,11 @@ open Asttypes open Lambda type function_label = string -type arity = Lambda.function_kind * int +type arity = { + function_kind : Lambda.function_kind ; + params_layout : Lambda.layout list ; + return_layout : Lambda.layout ; +} type apply_kind = Lambda.region_close * Lambda.alloc_mode type ustructured_constant = @@ -49,9 +53,9 @@ and ulambda = Uvar of Backend_var.t | Uconst of uconstant | Udirect_apply of - function_label * ulambda list * Lambda.probe * apply_kind * Debuginfo.t + function_label * ulambda list * Lambda.probe * Lambda.layout * apply_kind * Debuginfo.t | Ugeneric_apply of - ulambda * ulambda list * apply_kind * Debuginfo.t + ulambda * ulambda list * Lambda.layout list * Lambda.layout * apply_kind * Debuginfo.t | Uclosure of { functions : ufunction list ; not_scanned_slots : ulambda list ; @@ -90,7 +94,7 @@ and ulambda = | Uassign of Backend_var.t * ulambda | Usend of meth_kind * ulambda * ulambda * ulambda list - * apply_kind * Debuginfo.t + * Lambda.layout list * Lambda.layout * apply_kind * Debuginfo.t | Uunreachable | Uregion of ulambda | Utail of ulambda @@ -98,8 +102,7 @@ and ulambda = and ufunction = { label : function_label; arity : arity; - params : (Backend_var.With_provenance.t * layout) list; - return : layout; + params : Backend_var.With_provenance.t list; body : ulambda; dbg : Debuginfo.t; env : Backend_var.t option; diff --git a/middle_end/clambda.mli b/middle_end/clambda.mli index 48fec9eebe5..041e05536e4 100644 --- a/middle_end/clambda.mli +++ b/middle_end/clambda.mli @@ -20,7 +20,11 @@ open Asttypes open Lambda type function_label = string -type arity = Lambda.function_kind * int +type arity = { + function_kind : Lambda.function_kind ; + params_layout : Lambda.layout list ; + return_layout : Lambda.layout ; +} type apply_kind = Lambda.region_close * Lambda.alloc_mode type ustructured_constant = @@ -60,9 +64,9 @@ and ulambda = Uvar of Backend_var.t | Uconst of uconstant | Udirect_apply of - function_label * ulambda list * Lambda.probe * apply_kind * Debuginfo.t + function_label * ulambda list * Lambda.probe * Lambda.layout * apply_kind * Debuginfo.t | Ugeneric_apply of - ulambda * ulambda list * apply_kind * Debuginfo.t + ulambda * ulambda list * Lambda.layout list * Lambda.layout * apply_kind * Debuginfo.t | Uclosure of { functions : ufunction list ; not_scanned_slots : ulambda list ; @@ -101,7 +105,7 @@ and ulambda = | Uassign of Backend_var.t * ulambda | Usend of meth_kind * ulambda * ulambda * ulambda list - * apply_kind * Debuginfo.t + * Lambda.layout list * Lambda.layout * apply_kind * Debuginfo.t | Uunreachable | Uregion of ulambda | Utail of ulambda @@ -109,8 +113,7 @@ and ulambda = and ufunction = { label : function_label; arity : arity; - params : (Backend_var.With_provenance.t * layout) list; - return : layout; + params : Backend_var.With_provenance.t list; body : ulambda; dbg : Debuginfo.t; env : Backend_var.t option; diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml index d3cc1c9baf8..5cbc4517230 100644 --- a/middle_end/closure/closure.ml +++ b/middle_end/closure/closure.ml @@ -104,8 +104,8 @@ let occurs_var var u = let rec occurs = function Uvar v -> v = var | Uconst _ -> false - | Udirect_apply(_lbl, args, _, _, _) -> List.exists occurs args - | Ugeneric_apply(funct, args, _, _) -> + | Udirect_apply(_lbl, args, _, _, _, _) -> List.exists occurs args + | Ugeneric_apply(funct, args, _, _, _, _) -> occurs funct || List.exists occurs args | Uclosure { functions = _ ; not_scanned_slots ; scanned_slots } -> List.exists occurs not_scanned_slots || List.exists occurs scanned_slots @@ -131,7 +131,7 @@ let occurs_var var u = | Uwhile(cond, body) -> occurs cond || occurs body | Ufor(_id, lo, hi, _dir, body) -> occurs lo || occurs hi || occurs body | Uassign(id, u) -> id = var || occurs u - | Usend(_, met, obj, args, _, _) -> + | Usend(_, met, obj, args, _, _, _, _) -> occurs met || occurs obj || List.exists occurs args | Uunreachable -> false | Uregion e -> occurs e @@ -192,13 +192,13 @@ let lambda_smaller lam threshold = match lam with Uvar _ -> () | Uconst _ -> incr size - | Udirect_apply(_, args, None, _, _) -> + | Udirect_apply(_, args, None, _, _, _) -> size := !size + 4; lambda_list_size args | Udirect_apply _ -> () (* We aim for probe points to not affect inlining decisions. Actual cost is either 1, 5 or 6 bytes, depending on their kind, on x86-64. *) - | Ugeneric_apply(fn, args, _, _) -> + | Ugeneric_apply(fn, args, _, _, _, _) -> size := !size + 6; lambda_size fn; lambda_list_size args | Uclosure _ -> raise Exit (* inlining would duplicate function definitions *) @@ -243,7 +243,7 @@ let lambda_smaller lam threshold = size := !size + 4; lambda_size low; lambda_size high; lambda_size body | Uassign(_id, lam) -> incr size; lambda_size lam - | Usend(_, met, obj, args, _, _) -> + | Usend(_, met, obj, args, _, _, _, _) -> size := !size + 8; lambda_size met; lambda_size obj; lambda_list_size args | Uunreachable -> () @@ -605,14 +605,15 @@ let rec substitute loc ((backend, fpc) as st) sb rn ulam = Uvar v -> begin try V.Map.find v sb with Not_found -> ulam end | Uconst _ -> ulam - | Udirect_apply(lbl, args, probe, kind, dbg) -> + | Udirect_apply(lbl, args, probe, return_layout, kind, dbg) -> let dbg = subst_debuginfo loc dbg in Udirect_apply(lbl, List.map (substitute loc st sb rn) args, - probe, kind, dbg) - | Ugeneric_apply(fn, args, kind, dbg) -> + probe, return_layout, kind, dbg) + | Ugeneric_apply(fn, args, args_layout, return_layout, kind, dbg) -> let dbg = subst_debuginfo loc dbg in Ugeneric_apply(substitute loc st sb rn fn, - List.map (substitute loc st sb rn) args, kind, dbg) + List.map (substitute loc st sb rn) args, + args_layout, return_layout, kind, dbg) | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> (* Question: should we rename function labels as well? Otherwise, there is a risk that function labels are not globally unique. @@ -752,10 +753,10 @@ let rec substitute loc ((backend, fpc) as st) sb rn ulam = with Not_found -> id in Uassign(id', substitute loc st sb rn u) - | Usend(k, u1, u2, ul, pos, dbg) -> + | Usend(k, u1, u2, ul, args_layout, result_layout, pos, dbg) -> let dbg = subst_debuginfo loc dbg in Usend(k, substitute loc st sb rn u1, substitute loc st sb rn u2, - List.map (substitute loc st sb rn) ul, pos, dbg) + List.map (substitute loc st sb rn) ul, args_layout, result_layout, pos, dbg) | Uunreachable -> Uunreachable | Uregion e -> @@ -863,7 +864,7 @@ let fail_if_probe ~probe msg = (* Generate a direct application *) -let direct_apply env fundesc ufunct uargs pos mode ~probe ~loc ~attribute = +let direct_apply env fundesc ufunct uargs pos result_layout mode ~probe ~loc ~attribute = match fundesc.fun_inline, attribute with | _, Never_inlined | None, _ -> @@ -881,10 +882,10 @@ let direct_apply env fundesc ufunct uargs pos mode ~probe ~loc ~attribute = fail_if_probe ~probe "Erroneously marked to be inlined" end; if fundesc.fun_closed && is_pure ufunct then - Udirect_apply(fundesc.fun_label, uargs, probe, kind, dbg) + Udirect_apply(fundesc.fun_label, uargs, probe, result_layout, kind, dbg) else if not fundesc.fun_closed && is_substituable ~mutable_vars:env.mutable_vars ufunct then - Udirect_apply(fundesc.fun_label, uargs @ [ufunct], probe, kind, dbg) + Udirect_apply(fundesc.fun_label, uargs @ [ufunct], probe, result_layout, kind, dbg) else begin let args = List.map (fun arg -> if is_substituable ~mutable_vars:env.mutable_vars arg then @@ -900,12 +901,12 @@ let direct_apply env fundesc ufunct uargs pos mode ~probe ~loc ~attribute = (if fundesc.fun_closed then Usequence (ufunct, Udirect_apply (fundesc.fun_label, app_args, - probe, kind, dbg)) + probe, result_layout, kind, dbg)) else let clos = V.create_local "clos" in Ulet(Immutable, Lambda.layout_function, VP.create clos, ufunct, Udirect_apply(fundesc.fun_label, app_args @ [Uvar clos], - probe, kind, dbg))) + probe, result_layout, kind, dbg))) args end | Some(params, body), _ -> @@ -1022,35 +1023,41 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) when fun_arity > nargs *) | Lapply{ap_func = funct; ap_args = args; ap_region_close=pos; ap_mode=mode; ap_probe = probe; ap_loc = loc; - ap_inlined = attribute} -> + ap_inlined = attribute; ap_result_layout} -> let nargs = List.length args in if nargs = 0 && probe = None then Misc.fatal_errorf "Closure: 0-ary application at %a" Location.print_loc (Debuginfo.Scoped_location.to_location loc); begin match (close env funct, close_list env args) with ((ufunct, Value_closure(_, - ({fun_arity=(Tupled, nparams)} as fundesc), + ({fun_arity={ + function_kind = Tupled ; + params_layout; _}} as fundesc), approx_res)), [Uprim(P.Pmakeblock _, uargs, _)]) - when List.length uargs = nparams -> + when List.length uargs = List.length params_layout -> let app = direct_apply env ~loc ~attribute fundesc ufunct uargs - pos mode ~probe in + pos ap_result_layout mode ~probe in (app, strengthen_approx app approx_res) | ((ufunct, Value_closure(_, - ({fun_arity=(Curried _, nparams)} as fundesc), + ({fun_arity={ + function_kind = Curried _ ; + params_layout ; _}} as fundesc), approx_res)), uargs) - when nargs = nparams -> + when nargs = List.length params_layout -> let app = direct_apply env ~loc ~attribute fundesc ufunct uargs - pos mode ~probe in + pos ap_result_layout mode ~probe in (app, strengthen_approx app approx_res) | ((ufunct, (Value_closure( clos_mode, - ({fun_arity=(Curried {nlocal}, nparams)} as fundesc), + ({fun_arity={ function_kind = Curried {nlocal} ; + params_layout ; _ }} as fundesc), _) as fapprox)), uargs) - when nargs < nparams -> + when nargs < List.length params_layout -> + let nparams = List.length params_layout in let first_args = List.map (fun arg -> (V.create_local "arg", arg) ) uargs in (* CR mshinwell: Edit when Lapply has kinds *) @@ -1120,9 +1127,11 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) fail_if_probe ~probe "Partial application"; (new_fun, approx) - | ((ufunct, Value_closure(_, ({fun_arity = (Curried _, nparams)} as fundesc), + | ((ufunct, Value_closure(_, ({fun_arity = { + function_kind = Curried _; params_layout ; _}} as fundesc), _approx_res)), uargs) - when nargs > nparams -> + when nargs > List.length params_layout -> + let nparams = List.length params_layout in let args = List.map (fun arg -> V.create_local "arg", arg) uargs in (* CR mshinwell: Edit when Lapply has kinds *) let kinds = @@ -1139,9 +1148,12 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) let body = Ugeneric_apply(direct_apply { env with kinds } ~loc ~attribute fundesc ufunct first_args - Rc_normal mode' + Rc_normal Lambda.layout_function mode' ~probe, - rem_args, (Rc_normal, mode), dbg) + rem_args, + List.map (fun _ -> Lambda.layout_top) rem_args, + ap_result_layout, + (Rc_normal, mode), dbg) in let body = match mode, fundesc.fun_region with @@ -1155,6 +1167,7 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) in let result = List.fold_left (fun body (id, defining_expr) -> + (* CR ncourant: we need to know the layout of defining_expr here, this is hard *) Ulet (Immutable, Lambda.layout_top, VP.create id, defining_expr, body)) body args @@ -1164,13 +1177,14 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) let dbg = Debuginfo.from_location loc in warning_if_forced_inlined ~loc ~attribute "Unknown function"; fail_if_probe ~probe "Unknown function"; - (Ugeneric_apply(ufunct, uargs, (pos, mode), dbg), Value_unknown) + (Ugeneric_apply(ufunct, uargs, List.map (fun _ -> Lambda.layout_top) uargs, ap_result_layout, (pos, mode), dbg), Value_unknown) end - | Lsend(kind, met, obj, args, pos, mode, loc, _result_layout) -> + | 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 - (Usend(kind, umet, uobj, close_list env args, (pos,mode), dbg), + let args_layout = List.map (fun _ -> Lambda.layout_top) args in + (Usend(kind, umet, uobj, close_list env args, args_layout, result_layout, (pos,mode), dbg), Value_unknown) | Llet(str, kind, id, lam, body) -> let (ulam, alam) = close_named env id lam in @@ -1277,7 +1291,7 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) in let arg, _approx = close env arg in let id = Ident.create_local "dummy" in - Ulet(Immutable, Lambda.layout_top, VP.create id, arg, cst), approx + Ulet(Immutable, Lambda.layout_unit, VP.create id, arg, cst), approx | Lprim(Pignore, [arg], _loc) -> let expr, approx = make_const_int 0 in Usequence(fst (close env arg), expr), approx @@ -1484,10 +1498,13 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ |> Symbol.linkage_name |> Linkage_name.to_string in - let arity = List.length params in let fundesc = {fun_label = label; - fun_arity = (kind, arity); + fun_arity = { + function_kind = kind ; + params_layout = List.map snd params ; + return_layout = return + }; fun_closed = initially_closed; fun_inline = None; fun_float_const_prop = !Clflags.float_const_prop; @@ -1516,7 +1533,9 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ (fun (_id, _params, _return, _body, _mode, _attrib, fundesc, _dbg) -> let pos = !env_pos + 1 in env_pos := !env_pos + 1 + - (match fundesc.fun_arity with (Curried _, (0|1)) -> 2 | _ -> 3); + (match fundesc.fun_arity with + | { function_kind = Curried _; params_layout = ([] | [_]); _} -> 2 + | _ -> 3); pos) uncurried_defs in let fv_pos = !env_pos in @@ -1566,8 +1585,7 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ { label = fundesc.fun_label; arity = fundesc.fun_arity; - params = List.map (fun (var, kind) -> VP.create var, kind) fun_params; - return; + params = List.map (fun (var, _) -> VP.create var) fun_params; body = ubody; dbg; env = Some env_param; @@ -1724,8 +1742,8 @@ let collect_exported_structured_constants a = and ulam = function | Uvar _ -> () | Uconst c -> const c - | Udirect_apply (_, ul, _, _, _) -> List.iter ulam ul - | Ugeneric_apply (u, ul, _, _) -> ulam u; List.iter ulam ul + | Udirect_apply (_, ul, _, _, _, _) -> List.iter ulam ul + | Ugeneric_apply (u, ul, _, _, _, _) -> ulam u; List.iter ulam ul | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> List.iter (fun f -> ulam f.body) functions; List.iter ulam not_scanned_slots; @@ -1751,7 +1769,7 @@ let collect_exported_structured_constants a = | Uifthenelse (u1, u2, u3, _) | Ufor (_, u1, u2, _, u3) -> ulam u1; ulam u2; ulam u3 | Uassign (_, u) -> ulam u - | Usend (_, u1, u2, ul, _, _) -> ulam u1; ulam u2; List.iter ulam ul + | Usend (_, u1, u2, ul, _, _, _, _) -> ulam u1; ulam u2; List.iter ulam ul | Uunreachable -> () | Uregion u -> ulam u | Utail u -> ulam u diff --git a/middle_end/flambda/flambda_to_clambda.ml b/middle_end/flambda/flambda_to_clambda.ml index 5b2ed7ee3f5..2440e85d03e 100644 --- a/middle_end/flambda/flambda_to_clambda.ml +++ b/middle_end/flambda/flambda_to_clambda.ml @@ -99,7 +99,11 @@ let clambda_arity (func : Flambda.function_declaration) : Clambda.arity = Lambda.is_local_mode (Parameter.alloc_mode p)) |> List.length in - Curried {nlocal}, Flambda_utils.function_arity func + { + function_kind = Curried {nlocal} ; + params_layout = List.map Parameter.kind func.params ; + return_layout = Lambda.layout_top ; (* Need func.return *) + } let check_field t ulam pos named_opt : Clambda.ulambda = if not !Clflags.clambda_checks then ulam @@ -273,8 +277,10 @@ let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda = to_clambda_direct_apply t func args direct_func probe dbg reg_close mode env | Apply { func; args; kind = Indirect; probe = None; dbg; reg_close; mode } -> let callee = subst_var env func in + let args_layout = List.map (fun _ -> Lambda.layout_top) args in + let result_layout = Lambda.layout_top in Ugeneric_apply (check_closure t callee (Flambda.Expr (Var func)), - subst_vars env args, (reg_close, mode), dbg) + subst_vars env args, args_layout, result_layout, (reg_close, mode), dbg) | Apply { probe = Some {name}; _ } -> Misc.fatal_errorf "Cannot apply indirect handler for probe %s" name () | Switch (arg, sw) -> @@ -354,8 +360,10 @@ let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda = in Uassign (id, subst_var env new_value) | Send { kind; meth; obj; args; dbg; reg_close; mode } -> + let args_layout = List.map (fun _ -> Lambda.layout_top) args in + let result_layout = Lambda.layout_top in Usend (kind, subst_var env meth, subst_var env obj, - subst_vars env args, (reg_close,mode), dbg) + subst_vars env args, args_layout, result_layout, (reg_close,mode), dbg) | Region body -> let body = to_clambda t env body in let is_trivial = @@ -483,7 +491,8 @@ and to_clambda_direct_apply t func args direct_func probe dbg pos mode env dropping any side effects.) *) if closed then uargs else uargs @ [subst_var env func] in - Udirect_apply (label, uargs, probe, (pos, mode), dbg) + let result_layout = Lambda.layout_top in + Udirect_apply (label, uargs, probe, result_layout, (pos, mode), dbg) (* Describe how to build a runtime closure block that corresponds to the given Flambda set of closures. @@ -562,7 +571,7 @@ and to_clambda_set_of_closures t env let env_body, params = List.fold_right (fun var (env, params) -> let id, env = Env.add_fresh_ident env (Parameter.var var) in - env, (VP.create id, Parameter.kind var) :: params) + env, VP.create id :: params) function_decl.params (env, []) in let label = @@ -572,8 +581,7 @@ and to_clambda_set_of_closures t env in { label; arity = clambda_arity function_decl; - params = params @ [VP.create env_var, Lambda.layout_function]; - return = Lambda.layout_top; + params = params @ [VP.create env_var]; body = to_clambda t env_body function_decl.body; dbg = function_decl.dbg; env = Some env_var; @@ -623,7 +631,7 @@ and to_clambda_closed_set_of_closures t env symbol let env_body, params = List.fold_right (fun var (env, params) -> let id, env = Env.add_fresh_ident env (Parameter.var var) in - env, (VP.create id, Parameter.kind var) :: params) + env, VP.create id :: params) function_decl.params (env, []) in let body = @@ -641,7 +649,6 @@ and to_clambda_closed_set_of_closures t env symbol { label; arity = clambda_arity function_decl; params; - return = Lambda.layout_top; body; dbg = function_decl.dbg; env = None; diff --git a/middle_end/flambda/un_anf.ml b/middle_end/flambda/un_anf.ml index 53c23cff956..32f6d54d9f4 100644 --- a/middle_end/flambda/un_anf.ml +++ b/middle_end/flambda/un_anf.ml @@ -56,6 +56,7 @@ let ignore_primitive (_ : Clambda_primitives.primitive) = () let ignore_string (_ : string) = () let ignore_int_array (_ : int array) = () let ignore_var_with_provenance (_ : VP.t) = () +let ignore_params (_ : VP.t list) = () let ignore_params_with_layout (_ : (VP.t * Lambda.layout) list) = () let ignore_direction_flag (_ : Asttypes.direction_flag) = () let ignore_meth_kind (_ : Lambda.meth_kind) = () @@ -67,9 +68,10 @@ let ignore_layout (_ : Lambda.layout) = () let closure_environment_var (ufunction:Clambda.ufunction) = (* The argument after the arity is the environment *) - match ufunction.arity with - | Curried _, n when List.length ufunction.params = n + 1 -> - let (env_var, _) = List.nth ufunction.params n in + let n = List.length ufunction.arity.params_layout in + match ufunction.arity.function_kind with + | Curried _ when List.length ufunction.params = n + 1 -> + let env_var = List.nth ufunction.params n in assert (VP.name env_var = "env"); Some env_var | _ -> @@ -134,21 +136,24 @@ let make_var_info (clam : Clambda.ulambda) : var_info = of the closures will be traversed when this function is called from [Flambda_to_clambda.to_clambda_closed_set_of_closures].) *) ignore_uconstant const - | Udirect_apply (label, args, _probe, info, dbg) -> + | Udirect_apply (label, args, _probe, result_layout, info, dbg) -> ignore_function_label label; List.iter (loop ~depth) args; + ignore_layout result_layout; ignore_apply_kind info; ignore_debuginfo dbg - | Ugeneric_apply (func, args, info, dbg) -> + | Ugeneric_apply (func, args, args_layout, result_layout, info, dbg) -> loop ~depth func; List.iter (loop ~depth) args; + List.iter ignore_layout args_layout; + ignore_layout result_layout; ignore_apply_kind info; ignore_debuginfo dbg | Uclosure { functions; not_scanned_slots ; scanned_slots } -> List.iter (loop ~depth) not_scanned_slots; List.iter (loop ~depth) scanned_slots; List.iter (fun ( - { Clambda. label; arity=_; params; return; body; dbg; env; mode=_; + { Clambda. label; arity=_; params; body; dbg; env; mode=_; check=_; poll=_ } as clos) -> (match closure_environment_var clos with | None -> () @@ -156,8 +161,7 @@ let make_var_info (clam : Clambda.ulambda) : var_info = environment_vars := V.Set.add (VP.var env_var) !environment_vars); ignore_function_label label; - ignore_params_with_layout params; - ignore_layout return; + ignore_params params; loop ~depth:(depth + 1) body; ignore_debuginfo dbg; ignore_var_option env) @@ -230,11 +234,13 @@ let make_var_info (clam : Clambda.ulambda) : var_info = | Uassign (var, expr) -> add_assignment t var; loop ~depth expr - | Usend (meth_kind, e1, e2, args, info, dbg) -> + | Usend (meth_kind, e1, e2, args, args_layout, result_layout, info, dbg) -> ignore_meth_kind meth_kind; loop ~depth e1; loop ~depth e2; List.iter (loop ~depth) args; + List.iter ignore_layout args_layout; + ignore_layout result_layout; ignore_apply_kind info; ignore_debuginfo dbg | Uunreachable -> @@ -309,28 +315,30 @@ let let_bound_vars_that_can_be_moved var_info (clam : Clambda.ulambda) = end | Uconst const -> ignore_uconstant const - | Udirect_apply (label, args, probe, info, dbg) -> + | Udirect_apply (label, args, probe, result_layout, info, dbg) -> ignore_function_label label; examine_argument_list args; (* We don't currently traverse [args]; they should all be variables anyway. If this is added in the future, take care to traverse [args] following the evaluation order. *) ignore_probe probe; + ignore_layout result_layout; ignore_apply_kind info; ignore_debuginfo dbg - | Ugeneric_apply (func, args, info, dbg) -> + | Ugeneric_apply (func, args, args_layout, result_layout, info, dbg) -> examine_argument_list (args @ [func]); + List.iter ignore_layout args_layout; + ignore_layout result_layout; ignore_apply_kind info; ignore_debuginfo dbg | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> ignore_ulambda_list not_scanned_slots; ignore_ulambda_list scanned_slots; (* Start a new let stack for speed. *) - List.iter (fun {Clambda. label; arity=_; params; return; body; dbg; env; mode=_; + List.iter (fun {Clambda. label; arity=_; params; body; dbg; env; mode=_; check=_; poll=_} -> ignore_function_label label; - ignore_params_with_layout params; - ignore_layout return; + ignore_params params; let_stack := []; loop body; let_stack := []; @@ -459,11 +467,13 @@ let let_bound_vars_that_can_be_moved var_info (clam : Clambda.ulambda) = ignore_var var; ignore_ulambda expr; let_stack := [] - | Usend (meth_kind, e1, e2, args, info, dbg) -> + | Usend (meth_kind, e1, e2, args, args_layout, result_layout, info, dbg) -> ignore_meth_kind meth_kind; ignore_ulambda e1; ignore_ulambda e2; ignore_ulambda_list args; + List.iter ignore_layout args_layout; + ignore_layout result_layout; let_stack := []; ignore_apply_kind info; ignore_debuginfo dbg @@ -496,13 +506,13 @@ let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda) V.print var end | Uconst _ -> clam - | Udirect_apply (label, args, probe, kind, dbg) -> + | Udirect_apply (label, args, probe, result_layout, kind, dbg) -> let args = substitute_let_moveable_list is_let_moveable env args in - Udirect_apply (label, args, probe, kind, dbg) - | Ugeneric_apply (func, args, kind, dbg) -> + Udirect_apply (label, args, probe, result_layout, kind, dbg) + | Ugeneric_apply (func, args, args_layout, result_layout, kind, dbg) -> let func = substitute_let_moveable is_let_moveable env func in let args = substitute_let_moveable_list is_let_moveable env args in - Ugeneric_apply (func, args, kind, dbg) + Ugeneric_apply (func, args, args_layout, result_layout, kind, dbg) | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> let functions = List.map (fun (ufunction : Clambda.ufunction) -> @@ -615,11 +625,11 @@ let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda) | Uassign (var, expr) -> let expr = substitute_let_moveable is_let_moveable env expr in Uassign (var, expr) - | Usend (kind, e1, e2, args, pos, dbg) -> + | Usend (kind, e1, e2, args, args_layout, result_layout, pos, dbg) -> let e1 = substitute_let_moveable is_let_moveable env e1 in let e2 = substitute_let_moveable is_let_moveable env e2 in let args = substitute_let_moveable_list is_let_moveable env args in - Usend (kind, e1, e2, args, pos, dbg) + Usend (kind, e1, e2, args, args_layout, result_layout, pos, dbg) | Uunreachable -> Uunreachable | Uregion e -> @@ -700,13 +710,13 @@ let rec un_anf_and_moveable var_info env (clam : Clambda.ulambda) | Uconst _ -> (* Constant closures are rewritten separately. *) clam, Constant - | Udirect_apply (label, args, probe, kind, dbg) -> + | Udirect_apply (label, args, probe, result_layout, kind, dbg) -> let args = un_anf_list var_info env args in - Udirect_apply (label, args, probe, kind, dbg), Fixed - | Ugeneric_apply (func, args, kind, dbg) -> + Udirect_apply (label, args, probe, result_layout, kind, dbg), Fixed + | Ugeneric_apply (func, args, args_layout, result_layout, kind, dbg) -> let func = un_anf var_info env func in let args = un_anf_list var_info env args in - Ugeneric_apply (func, args, kind, dbg), Fixed + Ugeneric_apply (func, args, args_layout, result_layout, kind, dbg), Fixed | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> let functions = List.map (fun (ufunction : Clambda.ufunction) -> @@ -844,11 +854,11 @@ let rec un_anf_and_moveable var_info env (clam : Clambda.ulambda) | Uassign (var, expr) -> let expr = un_anf var_info env expr in Uassign (var, expr), Fixed - | Usend (kind, e1, e2, args, pos, dbg) -> + | Usend (kind, e1, e2, args, args_layout, result_layout, pos, dbg) -> let e1 = un_anf var_info env e1 in let e2 = un_anf var_info env e2 in let args = un_anf_list var_info env args in - Usend (kind, e1, e2, args, pos, dbg), Fixed + Usend (kind, e1, e2, args, args_layout, result_layout, pos, dbg), Fixed | Uunreachable -> Uunreachable, Fixed | Uregion e -> 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 c2ae626cb5d..3c567a1ca0f 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 @@ -157,8 +157,7 @@ end = struct get_func_decl_params_arity env code_id in let closure_info = - C.closure_info - ~arity:(kind, List.length params_ty) + C.closure_info' ~arity:(kind, params_ty) ~startenv:(startenv - slot_offset) ~is_last:last_function_slot in let acc = diff --git a/middle_end/printclambda.ml b/middle_end/printclambda.ml index 69cd64bffd0..2c166ae1129 100644 --- a/middle_end/printclambda.ml +++ b/middle_end/printclambda.ml @@ -78,16 +78,23 @@ let rec structured_constant ppf = function and one_fun ppf f = let idents ppf = - List.iter - (fun (x, k) -> - fprintf ppf "@ %a%a" - VP.print x - Printlambda.layout k - ) + let rec iter params layouts = + match params, layouts with + | [], [] -> () + | [param], [] -> + fprintf ppf "@ %a%a" + VP.print param Printlambda.layout Lambda.layout_function + | param :: params, layout :: layouts -> + fprintf ppf "@ %a%a" + VP.print param Printlambda.layout layout; + iter params layouts + | _ -> Misc.fatal_error "arity inconsistent with params" + in + iter f.params f.arity.params_layout in - fprintf ppf "(fun@ %s%s%a@ %d@ @[<2>%a@]@ @[<2>%a@])" - f.label (layout f.return) Printlambda.check_attribute f.check - (snd f.arity) idents f.params lam f.body + fprintf ppf "(fun@ %s%s%a@ %d@ @[<2>%t@]@ @[<2>%a@])" + f.label (layout f.arity.return_layout) Printlambda.check_attribute f.check + (List.length f.arity.params_layout) idents lam f.body and phantom_defining_expr ppf = function | Uphantom_const const -> uconstant ppf const @@ -125,7 +132,7 @@ and lam ppf = function | Uvar id -> V.print ppf id | Uconst c -> uconstant ppf c - | Udirect_apply(f, largs, probe, kind, _) -> + | Udirect_apply(f, largs, probe, _, kind, _) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in let pr ppf (probe : Lambda.probe) = @@ -134,7 +141,7 @@ and lam ppf = function | Some {name} -> fprintf ppf " (probe %s)" name in fprintf ppf "@[<2>(%a*@ %s %a%a)@]" apply_kind kind f lams largs pr probe - | Ugeneric_apply(lfun, largs, kind, _) -> + | Ugeneric_apply(lfun, largs, _, _, kind, _) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(%a@ %a%a)@]" apply_kind kind lam lfun lams largs @@ -257,7 +264,7 @@ and lam ppf = function lam hi lam body | Uassign(id, expr) -> fprintf ppf "@[<2>(assign@ %a@ %a)@]" V.print id lam expr - | Usend (k, met, obj, largs, (pos,_) , _) -> + | Usend (k, met, obj, largs, _, _, (pos,_) , _) -> let form = match pos with | Rc_normal | Rc_nontail -> "send" @@ -291,10 +298,11 @@ let rec approx ppf = function Value_closure(_, fundesc, a) -> Format.fprintf ppf "@[<2>function %s" fundesc.fun_label; - begin match fundesc.fun_arity with - | Tupled, n -> Format.fprintf ppf "@ arity -%i" n - | Curried {nlocal=0}, n -> Format.fprintf ppf "@ arity %i" n - | Curried {nlocal=k}, n -> Format.fprintf ppf "@ arity %i(%i L)" n k + let n = List.length fundesc.fun_arity.params_layout in + begin match fundesc.fun_arity.function_kind with + | Tupled -> Format.fprintf ppf "@ arity -%i" n + | Curried {nlocal=0} -> Format.fprintf ppf "@ arity %i" n + | Curried {nlocal=k} -> Format.fprintf ppf "@ arity %i(%i L)" n k end; if fundesc.fun_closed then begin Format.fprintf ppf "@ (closed)" diff --git a/ocaml/asmcomp/cmm_helpers.ml b/ocaml/asmcomp/cmm_helpers.ml index 6db885b509c..71cf2f4d093 100644 --- a/ocaml/asmcomp/cmm_helpers.ml +++ b/ocaml/asmcomp/cmm_helpers.ml @@ -80,12 +80,7 @@ let caml_int64_ops = "caml_int64_ops" let pos_arity_in_closinfo = 8 * size_addr - 8 (* arity = the top 8 bits of the closinfo word *) -let closure_info ~arity ~startenv ~is_last = - let arity = - match arity with - | Lambda.Tupled, n -> -n - | Lambda.Curried _, n -> n - in +let pack_closure_info ~arity ~startenv ~is_last = assert (-128 <= arity && arity <= 127); assert (0 <= startenv && startenv < 1 lsl (pos_arity_in_closinfo - 2)); Nativeint.(add (shift_left (of_int arity) pos_arity_in_closinfo) @@ -95,6 +90,19 @@ let closure_info ~arity ~startenv ~is_last = (pos_arity_in_closinfo - 1)) (add (shift_left (of_int startenv) 1) 1n))) +let closure_info' ~arity ~startenv ~is_last = + let arity = + match arity with + | Lambda.Tupled, l -> -List.length l + | Lambda.Curried _, l -> List.length l + in + pack_closure_info ~arity ~startenv ~is_last + +let closure_info ~(arity : Clambda.arity) ~startenv ~is_last = + closure_info' + ~arity:(arity.function_kind, arity.params_layout) + ~startenv ~is_last + let alloc_float_header mode dbg = match mode with | Lambda.Alloc_heap -> Cconst_natint (float_header, dbg) @@ -2271,7 +2279,6 @@ let intermediate_curry_functions ~nlocal ~arity result = let mode : Lambda.alloc_mode = if num >= narity - nlocal then Lambda.alloc_local else Lambda.alloc_heap in - let curried n = Lambda.Curried { nlocal = min nlocal n }, n in let has_nary = curry_clos_has_nary_application ~narity (num + 1) in let function_slot_size = if has_nary then 3 else 2 in Cfunction @@ -2284,11 +2291,14 @@ let intermediate_curry_functions ~nlocal ~arity result = (function_slot_size + machtype_stored_size arg_type + 1) (dbg ()); Cconst_symbol (name1 ^ "_" ^ Int.to_string (num + 1), dbg ()); - alloc_closure_info - ~arity:(curried (if has_nary then narity - num - 1 else 1)) - ~startenv: - (function_slot_size + machtype_non_scanned_size arg_type) - (dbg ()) ~is_last:true ] + Cconst_natint + ( pack_closure_info + ~arity:(if has_nary then narity - num - 1 else 1) + ~startenv: + (function_slot_size + + machtype_non_scanned_size arg_type) + ~is_last:true, + dbg () ) ] @ (if has_nary then [ Cconst_symbol @@ -3018,7 +3028,7 @@ let fundecls_size fundecls = (fun (f : Clambda.ufunction) -> let indirect_call_code_pointer_size = match f.arity with - | Curried _, (0 | 1) -> 0 + | { function_kind = Curried _; params_layout = [] | [_]; _ } -> 0 (* arity 1 does not need an indirect call handler. arity 0 cannot be indirect called *) | _ -> 1 @@ -3053,7 +3063,7 @@ let emit_constant_closure ((_, global_symb) as symb) fundecls clos_vars cont = | (f2 : Clambda.ufunction) :: rem -> ( let is_last = match rem with [] -> true | _ :: _ -> false in match f2.arity with - | (Curried _, (0 | 1)) as arity -> + | { function_kind = Curried _; params_layout = [] | [_]; _ } as arity -> (Cint (infix_header pos) :: closure_symbol f2) @ Csymbol_address f2.label :: Cint (closure_info ~arity ~startenv:(startenv - pos) ~is_last) @@ -3061,9 +3071,9 @@ let emit_constant_closure ((_, global_symb) as symb) fundecls clos_vars cont = | arity -> (Cint (infix_header pos) :: closure_symbol f2) @ Csymbol_address - (curry_function_sym (fst arity) - (List.init (snd arity) (fun _ -> typ_val)) - typ_val) + (curry_function_sym arity.function_kind + (List.map machtype_of_layout arity.params_layout) + (machtype_of_layout arity.return_layout)) :: Cint (closure_info ~arity ~startenv:(startenv - pos) ~is_last) :: Csymbol_address f2.label :: emit_others (pos + 4) rem) @@ -3074,15 +3084,15 @@ let emit_constant_closure ((_, global_symb) as symb) fundecls clos_vars cont = @ closure_symbol f1 @ match f1.arity with - | (Curried _, (0 | 1)) as arity -> + | { function_kind = Curried _; params_layout = [] | [_]; _ } as arity -> Csymbol_address f1.label :: Cint (closure_info ~arity ~startenv ~is_last) :: emit_others 3 remainder | arity -> Csymbol_address - (curry_function_sym (fst arity) - (List.init (snd arity) (fun _ -> typ_val)) - typ_val) + (curry_function_sym arity.function_kind + (List.map machtype_of_layout arity.params_layout) + (machtype_of_layout arity.return_layout)) :: Cint (closure_info ~arity ~startenv ~is_last) :: Csymbol_address f1.label :: emit_others 4 remainder) diff --git a/ocaml/asmcomp/cmm_helpers.mli b/ocaml/asmcomp/cmm_helpers.mli index e321cea27b5..8fc3f24304e 100644 --- a/ocaml/asmcomp/cmm_helpers.mli +++ b/ocaml/asmcomp/cmm_helpers.mli @@ -62,11 +62,20 @@ val boxedintnat_header : nativeint val closure_info : arity:Clambda.arity -> startenv:int -> is_last:bool -> nativeint +val closure_info' : + arity:Lambda.function_kind * 'a list -> + startenv:int -> + is_last:bool -> + nativeint + (** Wrappers *) val alloc_infix_header : int -> Debuginfo.t -> expression val alloc_closure_info : - arity:(Lambda.function_kind * int) -> startenv:int -> is_last:bool -> - Debuginfo.t -> expression + arity:Clambda.arity -> + startenv:int -> + is_last:bool -> + Debuginfo.t -> + expression (** Integers *) diff --git a/ocaml/asmcomp/cmmgen.ml b/ocaml/asmcomp/cmmgen.ml index bea40d61ad7..42f269afc9c 100644 --- a/ocaml/asmcomp/cmmgen.ml +++ b/ocaml/asmcomp/cmmgen.ml @@ -401,15 +401,18 @@ let rec transl env e = let dbg = f.dbg in let without_header = match f.arity with - | Curried _, (1|0) as arity -> + | { function_kind = Curried _ ; params_layout = ([] | [_]) } as arity -> Cconst_symbol (f.label, dbg) :: alloc_closure_info ~arity ~startenv:(startenv - pos) ~is_last dbg :: transl_fundecls (pos + 3) rem | arity -> - Cconst_symbol ( - curry_function_sym (fst arity) - (List.init (snd arity) (fun _ -> typ_val)) typ_val, dbg) :: + Cconst_symbol + (curry_function_sym + arity.function_kind + (List.map machtype_of_layout arity.params_layout) + (machtype_of_layout arity.return_layout), + dbg) :: alloc_closure_info ~arity ~startenv:(startenv - pos) ~is_last dbg :: Cconst_symbol (f.label, dbg) :: @@ -430,26 +433,25 @@ let rec transl env e = let ptr = transl env arg in let dbg = Debuginfo.none in ptr_offset ptr offset dbg - | Udirect_apply(handler_code_sym, args, Some { name; }, _, dbg) -> + | Udirect_apply(handler_code_sym, args, Some { name; }, _, _, dbg) -> let args = List.map (transl env) args in return_unit dbg (Cop(Cprobe { name; handler_code_sym; }, args, dbg)) - | Udirect_apply(lbl, args, None, kind, dbg) -> + | Udirect_apply(lbl, args, None, result_layout, kind, dbg) -> let args = List.map (transl env) args in - let return = typ_val in - direct_apply lbl return args kind dbg - | Ugeneric_apply(clos, args, kind, dbg) -> + direct_apply lbl (machtype_of_layout result_layout) args kind dbg + | Ugeneric_apply(clos, args, args_layout, result_layout, kind, dbg) -> let clos = transl env clos in let args = List.map (transl env) args in - let args_type = List.map (fun _ -> typ_val) args in - let return = typ_val in + let args_type = List.map machtype_of_layout args_layout in + let return = machtype_of_layout result_layout in generic_apply (mut_from_env env clos) clos args args_type return kind dbg - | Usend(kind, met, obj, args, pos, dbg) -> + | Usend(kind, met, obj, args, args_layout, result_layout, pos, dbg) -> let met = transl env met in let obj = transl env obj in let args = List.map (transl env) args in - let args_type = List.map (fun _ -> typ_val) args in - let return = typ_val in + let args_type = List.map machtype_of_layout args_layout in + let return = machtype_of_layout result_layout in send kind met obj args args_type return pos dbg | Ulet(str, kind, id, exp, body) -> transl_let env str kind id exp (fun env -> transl env body) @@ -1432,8 +1434,15 @@ let transl_function f = else [ Reduce_code_size ] in + let params_layout = + if List.length f.params = List.length f.arity.params_layout then + f.arity.params_layout + else + f.arity.params_layout @ [Lambda.layout_function] + in Cfunction {fun_name = f.label; - fun_args = List.map (fun (id, _) -> (id, typ_val)) f.params; + fun_args = List.map2 (fun id ty -> (id, machtype_of_layout ty)) + f.params params_layout; fun_body = cmm_body; fun_codegen_options; fun_poll = f.poll; diff --git a/ocaml/middle_end/clambda.ml b/ocaml/middle_end/clambda.ml index a00e144f4a8..8027fd5cd9e 100644 --- a/ocaml/middle_end/clambda.ml +++ b/ocaml/middle_end/clambda.ml @@ -20,7 +20,11 @@ open Asttypes open Lambda type function_label = string -type arity = Lambda.function_kind * int +type arity = { + function_kind : Lambda.function_kind ; + params_layout : Lambda.layout list ; + return_layout : Lambda.layout ; +} type apply_kind = Lambda.region_close * Lambda.alloc_mode type ustructured_constant = @@ -49,9 +53,9 @@ and ulambda = Uvar of Backend_var.t | Uconst of uconstant | Udirect_apply of - function_label * ulambda list * Lambda.probe * apply_kind * Debuginfo.t + function_label * ulambda list * Lambda.probe * Lambda.layout * apply_kind * Debuginfo.t | Ugeneric_apply of - ulambda * ulambda list * apply_kind * Debuginfo.t + ulambda * ulambda list * Lambda.layout list * Lambda.layout * apply_kind * Debuginfo.t | Uclosure of { functions : ufunction list ; not_scanned_slots : ulambda list ; @@ -90,7 +94,7 @@ and ulambda = | Uassign of Backend_var.t * ulambda | Usend of meth_kind * ulambda * ulambda * ulambda list - * apply_kind * Debuginfo.t + * Lambda.layout list * Lambda.layout * apply_kind * Debuginfo.t | Uunreachable | Uregion of ulambda | Utail of ulambda @@ -98,8 +102,7 @@ and ulambda = and ufunction = { label : function_label; arity : arity; - params : (Backend_var.With_provenance.t * layout) list; - return : layout; + params : Backend_var.With_provenance.t list; body : ulambda; dbg : Debuginfo.t; env : Backend_var.t option; diff --git a/ocaml/middle_end/clambda.mli b/ocaml/middle_end/clambda.mli index 35487361b65..19efda8dbe7 100644 --- a/ocaml/middle_end/clambda.mli +++ b/ocaml/middle_end/clambda.mli @@ -20,7 +20,11 @@ open Asttypes open Lambda type function_label = string -type arity = Lambda.function_kind * int +type arity = { + function_kind : Lambda.function_kind ; + params_layout : Lambda.layout list ; + return_layout : Lambda.layout ; +} type apply_kind = Lambda.region_close * Lambda.alloc_mode type ustructured_constant = @@ -60,9 +64,9 @@ and ulambda = Uvar of Backend_var.t | Uconst of uconstant | Udirect_apply of - function_label * ulambda list * Lambda.probe * apply_kind * Debuginfo.t + function_label * ulambda list * Lambda.probe * Lambda.layout * apply_kind * Debuginfo.t | Ugeneric_apply of - ulambda * ulambda list * apply_kind * Debuginfo.t + ulambda * ulambda list * Lambda.layout list * Lambda.layout * apply_kind * Debuginfo.t | Uclosure of { functions : ufunction list ; not_scanned_slots : ulambda list ; @@ -101,7 +105,7 @@ and ulambda = | Uassign of Backend_var.t * ulambda | Usend of meth_kind * ulambda * ulambda * ulambda list - * apply_kind * Debuginfo.t + * Lambda.layout list * Lambda.layout * apply_kind * Debuginfo.t | Uunreachable | Uregion of ulambda | Utail of ulambda @@ -109,8 +113,7 @@ and ulambda = and ufunction = { label : function_label; arity : arity; - params : (Backend_var.With_provenance.t * layout) list; - return : layout; + params : Backend_var.With_provenance.t list; body : ulambda; dbg : Debuginfo.t; env : Backend_var.t option; diff --git a/ocaml/middle_end/closure/closure.ml b/ocaml/middle_end/closure/closure.ml index da4e4e60724..9286db10512 100644 --- a/ocaml/middle_end/closure/closure.ml +++ b/ocaml/middle_end/closure/closure.ml @@ -104,8 +104,8 @@ let occurs_var var u = let rec occurs = function Uvar v -> v = var | Uconst _ -> false - | Udirect_apply(_lbl, args, _, _, _) -> List.exists occurs args - | Ugeneric_apply(funct, args, _, _) -> + | Udirect_apply(_lbl, args, _, _, _, _) -> List.exists occurs args + | Ugeneric_apply(funct, args, _, _, _, _) -> occurs funct || List.exists occurs args | Uclosure { functions = _ ; not_scanned_slots ; scanned_slots } -> List.exists occurs not_scanned_slots || List.exists occurs scanned_slots @@ -131,7 +131,7 @@ let occurs_var var u = | Uwhile(cond, body) -> occurs cond || occurs body | Ufor(_id, lo, hi, _dir, body) -> occurs lo || occurs hi || occurs body | Uassign(id, u) -> id = var || occurs u - | Usend(_, met, obj, args, _, _) -> + | Usend(_, met, obj, args, _, _, _, _) -> occurs met || occurs obj || List.exists occurs args | Uunreachable -> false | Uregion e -> occurs e @@ -192,13 +192,13 @@ let lambda_smaller lam threshold = match lam with Uvar _ -> () | Uconst _ -> incr size - | Udirect_apply(_, args, None, _, _) -> + | Udirect_apply(_, args, None, _, _, _) -> size := !size + 4; lambda_list_size args | Udirect_apply _ -> () (* We aim for probe points to not affect inlining decisions. Actual cost is either 1, 5 or 6 bytes, depending on their kind, on x86-64. *) - | Ugeneric_apply(fn, args, _, _) -> + | Ugeneric_apply(fn, args, _, _, _, _) -> size := !size + 6; lambda_size fn; lambda_list_size args | Uclosure _ -> raise Exit (* inlining would duplicate function definitions *) @@ -243,7 +243,7 @@ let lambda_smaller lam threshold = size := !size + 4; lambda_size low; lambda_size high; lambda_size body | Uassign(_id, lam) -> incr size; lambda_size lam - | Usend(_, met, obj, args, _, _) -> + | Usend(_, met, obj, args, _, _, _, _) -> size := !size + 8; lambda_size met; lambda_size obj; lambda_list_size args | Uunreachable -> () @@ -605,14 +605,15 @@ let rec substitute loc ((backend, fpc) as st) sb rn ulam = Uvar v -> begin try V.Map.find v sb with Not_found -> ulam end | Uconst _ -> ulam - | Udirect_apply(lbl, args, probe, kind, dbg) -> + | Udirect_apply(lbl, args, probe, return_layout, kind, dbg) -> let dbg = subst_debuginfo loc dbg in Udirect_apply(lbl, List.map (substitute loc st sb rn) args, - probe, kind, dbg) - | Ugeneric_apply(fn, args, kind, dbg) -> + probe, return_layout, kind, dbg) + | Ugeneric_apply(fn, args, args_layout, return_layout, kind, dbg) -> let dbg = subst_debuginfo loc dbg in Ugeneric_apply(substitute loc st sb rn fn, - List.map (substitute loc st sb rn) args, kind, dbg) + List.map (substitute loc st sb rn) args, + args_layout, return_layout, kind, dbg) | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> (* Question: should we rename function labels as well? Otherwise, there is a risk that function labels are not globally unique. @@ -752,10 +753,10 @@ let rec substitute loc ((backend, fpc) as st) sb rn ulam = with Not_found -> id in Uassign(id', substitute loc st sb rn u) - | Usend(k, u1, u2, ul, pos, dbg) -> + | Usend(k, u1, u2, ul, args_layout, result_layout, pos, dbg) -> let dbg = subst_debuginfo loc dbg in Usend(k, substitute loc st sb rn u1, substitute loc st sb rn u2, - List.map (substitute loc st sb rn) ul, pos, dbg) + List.map (substitute loc st sb rn) ul, args_layout, result_layout, pos, dbg) | Uunreachable -> Uunreachable | Uregion e -> @@ -863,7 +864,7 @@ let fail_if_probe ~probe msg = (* Generate a direct application *) -let direct_apply env fundesc ufunct uargs pos mode ~probe ~loc ~attribute = +let direct_apply env fundesc ufunct uargs pos result_layout mode ~probe ~loc ~attribute = match fundesc.fun_inline, attribute with | _, Never_inlined | None, _ -> @@ -881,10 +882,10 @@ let direct_apply env fundesc ufunct uargs pos mode ~probe ~loc ~attribute = fail_if_probe ~probe "Erroneously marked to be inlined" end; if fundesc.fun_closed && is_pure ufunct then - Udirect_apply(fundesc.fun_label, uargs, probe, kind, dbg) + Udirect_apply(fundesc.fun_label, uargs, probe, result_layout, kind, dbg) else if not fundesc.fun_closed && is_substituable ~mutable_vars:env.mutable_vars ufunct then - Udirect_apply(fundesc.fun_label, uargs @ [ufunct], probe, kind, dbg) + Udirect_apply(fundesc.fun_label, uargs @ [ufunct], probe, result_layout, kind, dbg) else begin let args = List.map (fun arg -> if is_substituable ~mutable_vars:env.mutable_vars arg then @@ -900,12 +901,12 @@ let direct_apply env fundesc ufunct uargs pos mode ~probe ~loc ~attribute = (if fundesc.fun_closed then Usequence (ufunct, Udirect_apply (fundesc.fun_label, app_args, - probe, kind, dbg)) + probe, result_layout, kind, dbg)) else let clos = V.create_local "clos" in Ulet(Immutable, Lambda.layout_function, VP.create clos, ufunct, Udirect_apply(fundesc.fun_label, app_args @ [Uvar clos], - probe, kind, dbg))) + probe, result_layout, kind, dbg))) args end | Some(params, body), _ -> @@ -1023,7 +1024,7 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) when fun_arity > nargs *) | Lapply{ap_func = funct; ap_args = args; ap_region_close=pos; ap_mode=mode; ap_probe = probe; ap_loc = loc; - ap_inlined = attribute} -> + ap_inlined = attribute; ap_result_layout} -> let nargs = List.length args in if nargs = 0 && probe = None then Misc.fatal_errorf "Closure: 0-ary application at %a" @@ -1031,28 +1032,34 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) assert (nargs > 0); begin match (close env funct, close_list env args) with ((ufunct, Value_closure(_, - ({fun_arity=(Tupled, nparams)} as fundesc), + ({fun_arity={ + function_kind = Tupled ; + params_layout; _}} as fundesc), approx_res)), [Uprim(P.Pmakeblock _, uargs, _)]) - when List.length uargs = nparams -> + when List.length uargs = List.length params_layout -> let app = direct_apply env ~loc ~attribute fundesc ufunct uargs - pos mode ~probe in + pos ap_result_layout mode ~probe in (app, strengthen_approx app approx_res) | ((ufunct, Value_closure(_, - ({fun_arity=(Curried _, nparams)} as fundesc), + ({fun_arity={ + function_kind = Curried _ ; + params_layout ; _}} as fundesc), approx_res)), uargs) - when nargs = nparams -> + when nargs = List.length params_layout -> let app = direct_apply env ~loc ~attribute fundesc ufunct uargs - pos mode ~probe in + pos ap_result_layout mode ~probe in (app, strengthen_approx app approx_res) | ((ufunct, (Value_closure( clos_mode, - ({fun_arity=(Curried {nlocal}, nparams)} as fundesc), + ({fun_arity={ function_kind = Curried {nlocal} ; + params_layout ; _ }} as fundesc), _) as fapprox)), uargs) - when nargs < nparams -> + when nargs < List.length params_layout -> + let nparams = List.length params_layout in let first_args = List.map (fun arg -> (V.create_local "arg", arg) ) uargs in (* CR mshinwell: Edit when Lapply has kinds *) @@ -1125,9 +1132,11 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) fail_if_probe ~probe "Partial application"; (new_fun, approx) - | ((ufunct, Value_closure(_, ({fun_arity = (Curried _, nparams)} as fundesc), + | ((ufunct, Value_closure(_, ({fun_arity = { + function_kind = Curried _; params_layout ; _}} as fundesc), _approx_res)), uargs) - when nargs > nparams -> + when nargs > List.length params_layout -> + let nparams = List.length params_layout in let args = List.map (fun arg -> V.create_local "arg", arg) uargs in (* CR mshinwell: Edit when Lapply has kinds *) let kinds = @@ -1144,9 +1153,12 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) let body = Ugeneric_apply(direct_apply { env with kinds } ~loc ~attribute fundesc ufunct first_args - Rc_normal mode' + Rc_normal Lambda.layout_function mode' ~probe, - rem_args, (Rc_normal, mode), dbg) + rem_args, + List.map (fun _ -> Lambda.layout_top) rem_args, + ap_result_layout, + (Rc_normal, mode), dbg) in let body = match mode, fundesc.fun_region with @@ -1160,6 +1172,7 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) in let result = List.fold_left (fun body (id, defining_expr) -> + (* CR ncourant: we need to know the layout of defining_expr here, this is hard *) Ulet (Immutable, Lambda.layout_top, VP.create id, defining_expr, body)) body args @@ -1169,13 +1182,14 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) let dbg = Debuginfo.from_location loc in warning_if_forced_inlined ~loc ~attribute "Unknown function"; fail_if_probe ~probe "Unknown function"; - (Ugeneric_apply(ufunct, uargs, (pos, mode), dbg), Value_unknown) + (Ugeneric_apply(ufunct, uargs, List.map (fun _ -> Lambda.layout_top) uargs, ap_result_layout, (pos, mode), dbg), Value_unknown) end - | Lsend(kind, met, obj, args, pos, mode, loc, _result_layout) -> + | 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 - (Usend(kind, umet, uobj, close_list env args, (pos,mode), dbg), + let args_layout = List.map (fun _ -> Lambda.layout_top) args in + (Usend(kind, umet, uobj, close_list env args, args_layout, result_layout, (pos,mode), dbg), Value_unknown) | Llet(str, kind, id, lam, body) -> let (ulam, alam) = close_named env id lam in @@ -1269,7 +1283,7 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) in let arg, _approx = close env arg in let id = Ident.create_local "dummy" in - Ulet(Immutable, Lambda.layout_top, VP.create id, arg, cst), approx + Ulet(Immutable, Lambda.layout_unit, VP.create id, arg, cst), approx | Lprim(Pignore, [arg], _loc) -> let expr, approx = make_const_int 0 in Usequence(fst (close env arg), expr), approx @@ -1474,10 +1488,13 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ |> Symbol.linkage_name |> Linkage_name.to_string in - let arity = List.length params in let fundesc = {fun_label = label; - fun_arity = (kind, arity); + fun_arity = { + function_kind = kind ; + params_layout = List.map snd params ; + return_layout = return + }; fun_closed = initially_closed; fun_inline = None; fun_float_const_prop = !Clflags.float_const_prop; @@ -1506,7 +1523,9 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ (fun (_id, _params, _return, _body, _mode, fundesc, _dbg) -> let pos = !env_pos + 1 in env_pos := !env_pos + 1 + - (match fundesc.fun_arity with (Curried _, (0|1)) -> 2 | _ -> 3); + (match fundesc.fun_arity with + | { function_kind = Curried _; params_layout = ([] | [_]); _} -> 2 + | _ -> 3); pos) uncurried_defs in let fv_pos = !env_pos in @@ -1514,7 +1533,7 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ does not use its environment parameter is invalidated. *) let useless_env = ref initially_closed in (* Translate each function definition *) - let clos_fundef (id, params, return, body, mode, fundesc, dbg) env_pos = + let clos_fundef (id, params, _return, body, mode, fundesc, dbg) env_pos = let env_param = V.create_local "env" in let cenv_fv = add_to_closure_env env_param @@ -1556,8 +1575,7 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ { label = fundesc.fun_label; arity = fundesc.fun_arity; - params = List.map (fun (var, kind) -> VP.create var, kind) fun_params; - return; + params = List.map (fun (var, _) -> VP.create var) fun_params; body = ubody; dbg; env = Some env_param; @@ -1713,8 +1731,8 @@ let collect_exported_structured_constants a = and ulam = function | Uvar _ -> () | Uconst c -> const c - | Udirect_apply (_, ul, _, _, _) -> List.iter ulam ul - | Ugeneric_apply (u, ul, _, _) -> ulam u; List.iter ulam ul + | Udirect_apply (_, ul, _, _, _, _) -> List.iter ulam ul + | Ugeneric_apply (u, ul, _, _, _, _) -> ulam u; List.iter ulam ul | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> List.iter (fun f -> ulam f.body) functions; List.iter ulam not_scanned_slots; @@ -1740,7 +1758,7 @@ let collect_exported_structured_constants a = | Uifthenelse (u1, u2, u3, _) | Ufor (_, u1, u2, _, u3) -> ulam u1; ulam u2; ulam u3 | Uassign (_, u) -> ulam u - | Usend (_, u1, u2, ul, _, _) -> ulam u1; ulam u2; List.iter ulam ul + | Usend (_, u1, u2, ul, _, _, _, _) -> ulam u1; ulam u2; List.iter ulam ul | Uunreachable -> () | Uregion u -> ulam u | Utail u -> ulam u diff --git a/ocaml/middle_end/flambda/flambda_to_clambda.ml b/ocaml/middle_end/flambda/flambda_to_clambda.ml index b6d26ab3e89..d0af04edd56 100644 --- a/ocaml/middle_end/flambda/flambda_to_clambda.ml +++ b/ocaml/middle_end/flambda/flambda_to_clambda.ml @@ -98,7 +98,11 @@ let clambda_arity (func : Flambda.function_declaration) : Clambda.arity = |> List.filter (fun p -> Lambda.is_local_mode (Parameter.alloc_mode p)) |> List.length in - Curried {nlocal}, Flambda_utils.function_arity func + { + function_kind = Curried {nlocal} ; + params_layout = List.map Parameter.kind func.params ; + return_layout = Lambda.layout_top ; (* Need func.return *) + } let check_field t ulam pos named_opt : Clambda.ulambda = if not !Clflags.clambda_checks then ulam @@ -272,8 +276,10 @@ let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda = to_clambda_direct_apply t func args direct_func probe dbg reg_close mode env | Apply { func; args; kind = Indirect; probe = None; dbg; reg_close; mode } -> let callee = subst_var env func in + let args_layout = List.map (fun _ -> Lambda.layout_top) args in + let result_layout = Lambda.layout_top in Ugeneric_apply (check_closure t callee (Flambda.Expr (Var func)), - subst_vars env args, (reg_close, mode), dbg) + subst_vars env args, args_layout, result_layout, (reg_close, mode), dbg) | Apply { probe = Some {name}; _ } -> Misc.fatal_errorf "Cannot apply indirect handler for probe %s" name () | Switch (arg, sw) -> @@ -353,8 +359,10 @@ let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda = in Uassign (id, subst_var env new_value) | Send { kind; meth; obj; args; dbg; reg_close; mode } -> + let args_layout = List.map (fun _ -> Lambda.layout_top) args in + let result_layout = Lambda.layout_top in Usend (kind, subst_var env meth, subst_var env obj, - subst_vars env args, (reg_close,mode), dbg) + subst_vars env args, args_layout, result_layout, (reg_close,mode), dbg) | Region body -> let body = to_clambda t env body in let is_trivial = @@ -482,7 +490,8 @@ and to_clambda_direct_apply t func args direct_func probe dbg pos mode env dropping any side effects.) *) if closed then uargs else uargs @ [subst_var env func] in - Udirect_apply (label, uargs, probe, (pos, mode), dbg) + let result_layout = Lambda.layout_top in + Udirect_apply (label, uargs, probe, result_layout, (pos, mode), dbg) (* Describe how to build a runtime closure block that corresponds to the given Flambda set of closures. @@ -561,7 +570,7 @@ and to_clambda_set_of_closures t env let env_body, params = List.fold_right (fun var (env, params) -> let id, env = Env.add_fresh_ident env (Parameter.var var) in - env, (VP.create id, Parameter.kind var) :: params) + env, VP.create id :: params) function_decl.params (env, []) in let label = @@ -571,8 +580,7 @@ and to_clambda_set_of_closures t env in { label; arity = clambda_arity function_decl; - params = params @ [VP.create env_var, Lambda.layout_function]; - return = Lambda.layout_top; + params = params @ [VP.create env_var]; body = to_clambda t env_body function_decl.body; dbg = function_decl.dbg; env = Some env_var; @@ -621,7 +629,7 @@ and to_clambda_closed_set_of_closures t env symbol let env_body, params = List.fold_right (fun var (env, params) -> let id, env = Env.add_fresh_ident env (Parameter.var var) in - env, (VP.create id, Parameter.kind var) :: params) + env, VP.create id :: params) function_decl.params (env, []) in let body = @@ -636,7 +644,6 @@ and to_clambda_closed_set_of_closures t env symbol { label; arity = clambda_arity function_decl; params; - return = Lambda.layout_top; body; dbg = function_decl.dbg; env = None; diff --git a/ocaml/middle_end/flambda/un_anf.ml b/ocaml/middle_end/flambda/un_anf.ml index 09e130edbcc..809c14c01c9 100644 --- a/ocaml/middle_end/flambda/un_anf.ml +++ b/ocaml/middle_end/flambda/un_anf.ml @@ -55,6 +55,7 @@ let ignore_primitive (_ : Clambda_primitives.primitive) = () let ignore_string (_ : string) = () let ignore_int_array (_ : int array) = () let ignore_var_with_provenance (_ : VP.t) = () +let ignore_params (_ : VP.t list) = () let ignore_params_with_layout (_ : (VP.t * Lambda.layout) list) = () let ignore_direction_flag (_ : Asttypes.direction_flag) = () let ignore_meth_kind (_ : Lambda.meth_kind) = () @@ -66,9 +67,10 @@ let ignore_layout (_ : Lambda.layout) = () let closure_environment_var (ufunction:Clambda.ufunction) = (* The argument after the arity is the environment *) - match ufunction.arity with - | Curried _, n when List.length ufunction.params = n + 1 -> - let (env_var, _) = List.nth ufunction.params n in + let n = List.length ufunction.arity.params_layout in + match ufunction.arity.function_kind with + | Curried _ when List.length ufunction.params = n + 1 -> + let env_var = List.nth ufunction.params n in assert (VP.name env_var = "env"); Some env_var | _ -> @@ -133,29 +135,31 @@ let make_var_info (clam : Clambda.ulambda) : var_info = of the closures will be traversed when this function is called from [Flambda_to_clambda.to_clambda_closed_set_of_closures].) *) ignore_uconstant const - | Udirect_apply (label, args, _probe, info, dbg) -> + | Udirect_apply (label, args, _probe, result_layout, info, dbg) -> ignore_function_label label; List.iter (loop ~depth) args; + ignore_layout result_layout; ignore_apply_kind info; ignore_debuginfo dbg - | Ugeneric_apply (func, args, info, dbg) -> + | Ugeneric_apply (func, args, args_layout, result_layout, info, dbg) -> loop ~depth func; List.iter (loop ~depth) args; + List.iter ignore_layout args_layout; + ignore_layout result_layout; ignore_apply_kind info; ignore_debuginfo dbg | Uclosure { functions; not_scanned_slots ; scanned_slots } -> List.iter (loop ~depth) not_scanned_slots; List.iter (loop ~depth) scanned_slots; List.iter (fun ( - { Clambda. label; arity=_; params; return; body; dbg; env; mode=_; poll=_} as clos) -> + { Clambda. label; arity=_; params; body; dbg; env; mode=_; poll=_} as clos) -> (match closure_environment_var clos with | None -> () | Some env_var -> environment_vars := V.Set.add (VP.var env_var) !environment_vars); ignore_function_label label; - ignore_params_with_layout params; - ignore_layout return; + ignore_params params; loop ~depth:(depth + 1) body; ignore_debuginfo dbg; ignore_var_option env) @@ -228,11 +232,13 @@ let make_var_info (clam : Clambda.ulambda) : var_info = | Uassign (var, expr) -> add_assignment t var; loop ~depth expr - | Usend (meth_kind, e1, e2, args, info, dbg) -> + | Usend (meth_kind, e1, e2, args, args_layout, result_layout, info, dbg) -> ignore_meth_kind meth_kind; loop ~depth e1; loop ~depth e2; List.iter (loop ~depth) args; + List.iter ignore_layout args_layout; + ignore_layout result_layout; ignore_apply_kind info; ignore_debuginfo dbg | Uunreachable -> @@ -306,27 +312,29 @@ let let_bound_vars_that_can_be_moved var_info (clam : Clambda.ulambda) = end | Uconst const -> ignore_uconstant const - | Udirect_apply (label, args, probe, info, dbg) -> + | Udirect_apply (label, args, probe, result_layout, info, dbg) -> ignore_function_label label; examine_argument_list args; (* We don't currently traverse [args]; they should all be variables anyway. If this is added in the future, take care to traverse [args] following the evaluation order. *) ignore_probe probe; + ignore_layout result_layout; ignore_apply_kind info; ignore_debuginfo dbg - | Ugeneric_apply (func, args, info, dbg) -> + | Ugeneric_apply (func, args, args_layout, result_layout, info, dbg) -> examine_argument_list (args @ [func]); + List.iter ignore_layout args_layout; + ignore_layout result_layout; ignore_apply_kind info; ignore_debuginfo dbg | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> ignore_ulambda_list not_scanned_slots; ignore_ulambda_list scanned_slots; (* Start a new let stack for speed. *) - List.iter (fun {Clambda. label; arity=_; params; return; body; dbg; env; mode=_; poll=_} -> + List.iter (fun {Clambda. label; arity=_; params; body; dbg; env; mode=_; poll=_} -> ignore_function_label label; - ignore_params_with_layout params; - ignore_layout return; + ignore_params params; let_stack := []; loop body; let_stack := []; @@ -455,11 +463,13 @@ let let_bound_vars_that_can_be_moved var_info (clam : Clambda.ulambda) = ignore_var var; ignore_ulambda expr; let_stack := [] - | Usend (meth_kind, e1, e2, args, info, dbg) -> + | Usend (meth_kind, e1, e2, args, args_layout, result_layout, info, dbg) -> ignore_meth_kind meth_kind; ignore_ulambda e1; ignore_ulambda e2; ignore_ulambda_list args; + List.iter ignore_layout args_layout; + ignore_layout result_layout; let_stack := []; ignore_apply_kind info; ignore_debuginfo dbg @@ -492,13 +502,13 @@ let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda) V.print var end | Uconst _ -> clam - | Udirect_apply (label, args, probe, kind, dbg) -> + | Udirect_apply (label, args, probe, result_layout, kind, dbg) -> let args = substitute_let_moveable_list is_let_moveable env args in - Udirect_apply (label, args, probe, kind, dbg) - | Ugeneric_apply (func, args, kind, dbg) -> + Udirect_apply (label, args, probe, result_layout, kind, dbg) + | Ugeneric_apply (func, args, args_layout, result_layout, kind, dbg) -> let func = substitute_let_moveable is_let_moveable env func in let args = substitute_let_moveable_list is_let_moveable env args in - Ugeneric_apply (func, args, kind, dbg) + Ugeneric_apply (func, args, args_layout, result_layout, kind, dbg) | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> let functions = List.map (fun (ufunction : Clambda.ufunction) -> @@ -611,11 +621,11 @@ let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda) | Uassign (var, expr) -> let expr = substitute_let_moveable is_let_moveable env expr in Uassign (var, expr) - | Usend (kind, e1, e2, args, pos, dbg) -> + | Usend (kind, e1, e2, args, args_layout, result_layout, pos, dbg) -> let e1 = substitute_let_moveable is_let_moveable env e1 in let e2 = substitute_let_moveable is_let_moveable env e2 in let args = substitute_let_moveable_list is_let_moveable env args in - Usend (kind, e1, e2, args, pos, dbg) + Usend (kind, e1, e2, args, args_layout, result_layout, pos, dbg) | Uunreachable -> Uunreachable | Uregion e -> @@ -696,13 +706,13 @@ let rec un_anf_and_moveable var_info env (clam : Clambda.ulambda) | Uconst _ -> (* Constant closures are rewritten separately. *) clam, Constant - | Udirect_apply (label, args, probe, kind, dbg) -> + | Udirect_apply (label, args, probe, result_layout, kind, dbg) -> let args = un_anf_list var_info env args in - Udirect_apply (label, args, probe, kind, dbg), Fixed - | Ugeneric_apply (func, args, kind, dbg) -> + Udirect_apply (label, args, probe, result_layout, kind, dbg), Fixed + | Ugeneric_apply (func, args, args_layout, result_layout, kind, dbg) -> let func = un_anf var_info env func in let args = un_anf_list var_info env args in - Ugeneric_apply (func, args, kind, dbg), Fixed + Ugeneric_apply (func, args, args_layout, result_layout, kind, dbg), Fixed | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> let functions = List.map (fun (ufunction : Clambda.ufunction) -> @@ -840,11 +850,11 @@ let rec un_anf_and_moveable var_info env (clam : Clambda.ulambda) | Uassign (var, expr) -> let expr = un_anf var_info env expr in Uassign (var, expr), Fixed - | Usend (kind, e1, e2, args, pos, dbg) -> + | Usend (kind, e1, e2, args, args_layout, result_layout, pos, dbg) -> let e1 = un_anf var_info env e1 in let e2 = un_anf var_info env e2 in let args = un_anf_list var_info env args in - Usend (kind, e1, e2, args, pos, dbg), Fixed + Usend (kind, e1, e2, args, args_layout, result_layout, pos, dbg), Fixed | Uunreachable -> Uunreachable, Fixed | Uregion e -> diff --git a/ocaml/middle_end/printclambda.ml b/ocaml/middle_end/printclambda.ml index c6b719932db..b63d37b591e 100644 --- a/ocaml/middle_end/printclambda.ml +++ b/ocaml/middle_end/printclambda.ml @@ -78,15 +78,23 @@ let rec structured_constant ppf = function and one_fun ppf f = let idents ppf = - List.iter - (fun (x, k) -> - fprintf ppf "@ %a%a" - VP.print x - Printlambda.layout k - ) + let rec iter params layouts = + match params, layouts with + | [], [] -> () + | [param], [] -> + fprintf ppf "@ %a%a" + VP.print param Printlambda.layout Lambda.layout_function + | param :: params, layout :: layouts -> + fprintf ppf "@ %a%a" + VP.print param Printlambda.layout layout; + iter params layouts + | _ -> Misc.fatal_error "arity inconsistent with params" + in + iter f.params f.arity.params_layout in - fprintf ppf "(fun@ %s%s@ %d@ @[<2>%a@]@ @[<2>%a@])" - f.label (layout f.return) (snd f.arity) idents f.params lam f.body + fprintf ppf "(fun@ %s%s@ %d@ @[<2>%t@]@ @[<2>%a@])" + f.label (layout f.arity.return_layout) (List.length f.arity.params_layout) + idents lam f.body and phantom_defining_expr ppf = function | Uphantom_const const -> uconstant ppf const @@ -124,7 +132,7 @@ and lam ppf = function | Uvar id -> V.print ppf id | Uconst c -> uconstant ppf c - | Udirect_apply(f, largs, probe, kind, _) -> + | Udirect_apply(f, largs, probe, _, kind, _) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in let pr ppf (probe : Lambda.probe) = @@ -133,7 +141,7 @@ and lam ppf = function | Some {name} -> fprintf ppf " (probe %s)" name in fprintf ppf "@[<2>(%a*@ %s %a%a)@]" apply_kind kind f lams largs pr probe - | Ugeneric_apply(lfun, largs, kind, _) -> + | Ugeneric_apply(lfun, largs, _, _, kind, _) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(%a@ %a%a)@]" apply_kind kind lam lfun lams largs @@ -256,7 +264,7 @@ and lam ppf = function lam hi lam body | Uassign(id, expr) -> fprintf ppf "@[<2>(assign@ %a@ %a)@]" V.print id lam expr - | Usend (k, met, obj, largs, (pos,_) , _) -> + | Usend (k, met, obj, largs, _, _, (pos,_) , _) -> let form = match pos with | Rc_normal | Rc_nontail -> "send" @@ -290,10 +298,11 @@ let rec approx ppf = function Value_closure(_, fundesc, a) -> Format.fprintf ppf "@[<2>function %s" fundesc.fun_label; - begin match fundesc.fun_arity with - | Tupled, n -> Format.fprintf ppf "@ arity -%i" n - | Curried {nlocal=0}, n -> Format.fprintf ppf "@ arity %i" n - | Curried {nlocal=k}, n -> Format.fprintf ppf "@ arity %i(%i L)" n k + let n = List.length fundesc.fun_arity.params_layout in + begin match fundesc.fun_arity.function_kind with + | Tupled -> Format.fprintf ppf "@ arity -%i" n + | Curried {nlocal=0} -> Format.fprintf ppf "@ arity %i" n + | Curried {nlocal=k} -> Format.fprintf ppf "@ arity %i(%i L)" n k end; if fundesc.fun_closed then begin Format.fprintf ppf "@ (closed)"