diff options
| -rw-r--r-- | Changes | 4 | ||||
| -rw-r--r-- | bytecomp/bytegen.ml | 14 | ||||
| -rw-r--r-- | lambda/lambda.ml | 10 | ||||
| -rw-r--r-- | lambda/lambda.mli | 6 | ||||
| -rw-r--r-- | lambda/matching.ml | 18 | ||||
| -rw-r--r-- | lambda/printlambda.ml | 9 | ||||
| -rw-r--r-- | lambda/simplif.ml | 50 | ||||
| -rw-r--r-- | lambda/translattribute.ml | 31 | ||||
| -rw-r--r-- | lambda/translattribute.mli | 2 | ||||
| -rw-r--r-- | lambda/translclass.ml | 28 | ||||
| -rw-r--r-- | lambda/translcore.ml | 90 | ||||
| -rw-r--r-- | lambda/translcore.mli | 2 | ||||
| -rw-r--r-- | lambda/translmod.ml | 101 | ||||
| -rw-r--r-- | middle_end/closure/closure.ml | 29 | ||||
| -rw-r--r-- | middle_end/flambda/closure_conversion.ml | 8 |
15 files changed, 238 insertions, 164 deletions
@@ -138,6 +138,10 @@ Working version - #9514: optimize pattern-matching exhaustivity analysis in the single-row case (Gabriel Scherer, review by Stephen DOlan) +- #9442: refactor the implementation of the [@tailcall] attribute + to allow for a structured attribute payload + (Gabriel Scherer, review by Vladimir Keleshev and Nicolás Ojeda Bär) + ### Build system: - #9332, #9518, #9529: Cease storing C dependencies in the codebase. C diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 082cdf150b..006288a0d0 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -691,12 +691,14 @@ let rec comp_expr env exp sz cont = comp_expr env arg sz (add_const_unit cont) | Lprim(Pdirapply, [func;arg], loc) | Lprim(Prevapply, [arg;func], loc) -> - let exp = Lapply{ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=func; - ap_args=[arg]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} in + let exp = Lapply{ + ap_loc=loc; + ap_func=func; + ap_args=[arg]; + ap_tailcall=Default_tailcall; + ap_inlined=Default_inline; + ap_specialised=Default_specialise; + } in comp_expr env exp sz cont | Lprim(Pnot, [arg], _) -> let newcont = diff --git a/lambda/lambda.ml b/lambda/lambda.ml index 3ae909d408..5b1baa5d9e 100644 --- a/lambda/lambda.ml +++ b/lambda/lambda.ml @@ -224,6 +224,10 @@ type structured_constant = | Const_float_array of string list | Const_immstring of string +type tailcall_attribute = + | Should_be_tailcall (* [@tailcall] *) + | Default_tailcall (* no [@tailcall] attribute *) + type inline_attribute = | Always_inline (* [@inline] or [@inline always] *) | Never_inline (* [@inline never] *) @@ -324,7 +328,7 @@ and lambda_apply = { ap_func : lambda; ap_args : lambda list; ap_loc : scoped_location; - ap_should_be_tailcall : bool; + ap_tailcall : tailcall_attribute; ap_inlined : inline_attribute; ap_specialised : specialise_attribute; } @@ -779,13 +783,13 @@ let rename idmap lam = let shallow_map f = function | Lvar _ | Lconst _ as lam -> lam - | Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall; + | Lapply { ap_func; ap_args; ap_loc; ap_tailcall; ap_inlined; ap_specialised } -> Lapply { ap_func = f ap_func; ap_args = List.map f ap_args; ap_loc; - ap_should_be_tailcall; + ap_tailcall; ap_inlined; ap_specialised; } diff --git a/lambda/lambda.mli b/lambda/lambda.mli index bf651eb005..2c049b2c26 100644 --- a/lambda/lambda.mli +++ b/lambda/lambda.mli @@ -216,6 +216,10 @@ type structured_constant = | Const_float_array of string list | Const_immstring of string +type tailcall_attribute = + | Should_be_tailcall (* [@tailcall] *) + | Default_tailcall (* no [@tailcall] attribute *) + type inline_attribute = | Always_inline (* [@inline] or [@inline always] *) | Never_inline (* [@inline never] *) @@ -309,7 +313,7 @@ and lambda_apply = { ap_func : lambda; ap_args : lambda list; ap_loc : scoped_location; - ap_should_be_tailcall : bool; (* true if [@tailcall] was specified *) + ap_tailcall : tailcall_attribute; ap_inlined : inline_attribute; (* specified with the [@inlined] attribute *) ap_specialised : specialise_attribute; } diff --git a/lambda/matching.ml b/lambda/matching.ml index 30d7423f87..a70e34f40f 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -1836,7 +1836,7 @@ let inline_lazy_force_cond arg loc = Lprim (Psequor, [test_tag Obj.lazy_tag; test_tag Obj.forcing_tag], loc), Lapply - { ap_should_be_tailcall = false; + { ap_tailcall = Default_tailcall; ap_loc = loc; ap_func = force_fun; ap_args = [ varg ]; @@ -1870,17 +1870,17 @@ let inline_lazy_force_switch arg loc = (Obj.lazy_tag, Lapply - { ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=force_fun; - ap_args=[varg]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise + { ap_tailcall = Default_tailcall; + ap_loc = loc; + ap_func = force_fun; + ap_args = [varg]; + ap_inlined = Default_inline; + ap_specialised = Default_specialise } ); (Obj.forcing_tag, Lapply - { ap_should_be_tailcall = false; + { ap_tailcall = Default_tailcall; ap_loc = loc; ap_func = force_fun; ap_args = [ varg ]; @@ -1899,7 +1899,7 @@ let inline_lazy_force arg loc = instrumentation output. (see https://github.com/stedolan/crowbar/issues/14) *) Lapply - { ap_should_be_tailcall = false; + { ap_tailcall = Default_tailcall; ap_loc = loc; ap_func = Lazy.force code_force_lazy; ap_args = [ arg ]; diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml index b5cd62b95b..ec8432db19 100644 --- a/lambda/printlambda.ml +++ b/lambda/printlambda.ml @@ -506,9 +506,10 @@ let function_attribute ppf { inline; specialise; local; is_a_functor; stub } = | Never_local -> fprintf ppf "never_local@ " end -let apply_tailcall_attribute ppf tailcall = - if tailcall then - fprintf ppf " @@tailcall" +let apply_tailcall_attribute ppf = function + | Default_tailcall -> () + | Should_be_tailcall -> + fprintf ppf " tailcall" let apply_inlined_attribute ppf = function | Default_inline -> () @@ -531,7 +532,7 @@ let rec lam ppf = function let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(apply@ %a%a%a%a%a)@]" lam ap.ap_func lams ap.ap_args - apply_tailcall_attribute ap.ap_should_be_tailcall + apply_tailcall_attribute ap.ap_tailcall apply_inlined_attribute ap.ap_inlined apply_specialised_attribute ap.ap_specialised | Lfunction{kind; params; return; body; attr} -> diff --git a/lambda/simplif.ml b/lambda/simplif.ml index 648bc489a8..3ce1250837 100644 --- a/lambda/simplif.ml +++ b/lambda/simplif.ml @@ -219,23 +219,28 @@ let simplify_exits lam = | Prevapply, [x; Lapply ap] | Prevapply, [x; Levent (Lapply ap,_)] -> Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc} - | Prevapply, [x; f] -> Lapply {ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=f; - ap_args=[x]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} - + | Prevapply, [x; f] -> + Lapply { + ap_loc=loc; + ap_func=f; + ap_args=[x]; + ap_tailcall=Default_tailcall; + ap_inlined=Default_inline; + ap_specialised=Default_specialise; + } (* Simplify %apply, for n-ary functions with n > 1 *) | Pdirapply, [Lapply ap; x] | Pdirapply, [Levent (Lapply ap,_); x] -> Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc} - | Pdirapply, [f; x] -> Lapply {ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=f; - ap_args=[x]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} + | Pdirapply, [f; x] -> + Lapply { + ap_loc=loc; + ap_func=f; + ap_args=[x]; + ap_tailcall=Default_tailcall; + ap_inlined=Default_inline; + ap_specialised=Default_specialise; + } (* Simplify %identity *) | Pidentity, [e] -> e @@ -606,11 +611,18 @@ let rec emit_tail_infos is_tail lambda = | Lvar _ -> () | Lconst _ -> () | Lapply ap -> - if ap.ap_should_be_tailcall - && not is_tail - && Warnings.is_active Warnings.Expect_tailcall - then Location.prerr_warning (to_location ap.ap_loc) - Warnings.Expect_tailcall; + begin match ap.ap_tailcall with + | Default_tailcall -> () + | Should_be_tailcall -> + (* Note: we may want to instead check the call_kind, + which takes [is_tail_native_heuristic] into accout. + But then this means getting different warnings depending + on whether the native or bytecode compiler is used. *) + if not is_tail + && Warnings.is_active Warnings.Expect_tailcall + then Location.prerr_warning (to_location ap.ap_loc) + Warnings.Expect_tailcall; + end; emit_tail_infos false ap.ap_func; list_emit_tail_infos false ap.ap_args | Lfunction {body = lam} -> @@ -710,7 +722,7 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body ~attr ~loc = ap_func = Lvar inner_id; ap_args = args; ap_loc = Loc_unknown; - ap_should_be_tailcall = false; + ap_tailcall = Default_tailcall; ap_inlined = Default_inline; ap_specialised = Default_specialise; } diff --git a/lambda/translattribute.ml b/lambda/translattribute.ml index d2d48c842e..f73391f46e 100644 --- a/lambda/translattribute.ml +++ b/lambda/translattribute.ml @@ -274,18 +274,29 @@ let get_tailcall_attribute e = | {Parsetree.attr_name = {txt=("tailcall"|"ocaml.tailcall")}; _} -> true | _ -> false in - let tailcalls, exp_attributes = + let tailcalls, other_attributes = List.partition is_tailcall_attribute e.exp_attributes in - match tailcalls with - | [] -> false, e - | _ :: r -> - begin match r with - | [] -> () - | {Parsetree.attr_name = {txt;loc}; _} :: _ -> - Location.prerr_warning loc (Warnings.Duplicated_attribute txt) - end; - true, { e with exp_attributes } + let tailcall_attribute = match tailcalls with + | [] -> Default_tailcall + | {Parsetree.attr_name = {txt; loc}; attr_payload = payload} :: r -> + begin match r with + | [] -> () + | {Parsetree.attr_name = {txt;loc}; _} :: _ -> + Location.prerr_warning loc (Warnings.Duplicated_attribute txt) + end; + let payload_result : (_, _) result = match payload with + | PStr [] -> Ok Should_be_tailcall + | _ -> Error () + in + match payload_result with + | Ok tailcall_attribute -> tailcall_attribute + | Error () -> + let msg = "No payload is currently supported." in + Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg)); + Default_tailcall + in + tailcall_attribute, { e with exp_attributes = other_attributes } let check_attribute e {Parsetree.attr_name = { txt; loc }; _} = match txt with diff --git a/lambda/translattribute.mli b/lambda/translattribute.mli index bf22fd1c5d..6047ab5207 100644 --- a/lambda/translattribute.mli +++ b/lambda/translattribute.mli @@ -67,7 +67,7 @@ val get_and_remove_specialised_attribute val get_tailcall_attribute : Typedtree.expression - -> bool * Typedtree.expression + -> Lambda.tailcall_attribute * Typedtree.expression val add_function_attributes : Lambda.lambda diff --git a/lambda/translclass.ml b/lambda/translclass.ml index 49b3089bf9..fc3a7f4723 100644 --- a/lambda/translclass.ml +++ b/lambda/translclass.ml @@ -50,12 +50,14 @@ let lapply ap = Lapply ap let mkappl (func, args) = - Lapply {ap_should_be_tailcall=false; - ap_loc=Loc_unknown; - ap_func=func; - ap_args=args; - ap_inlined=Default_inline; - ap_specialised=Default_specialise};; + Lapply { + ap_loc=Loc_unknown; + ap_func=func; + ap_args=args; + ap_tailcall=Default_tailcall; + ap_inlined=Default_inline; + ap_specialised=Default_specialise; + };; let lsequence l1 l2 = if l2 = lambda_unit then l1 else Lsequence(l1, l2) @@ -491,12 +493,14 @@ let transl_class_rebind ~scopes cl vf = let obj_init = Ident.create_local "obj_init" and self = Ident.create_local "self" in let obj_init0 = - lapply {ap_should_be_tailcall=false; - ap_loc=Loc_unknown; - ap_func=Lvar obj_init; - ap_args=[Lvar self]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} + lapply { + ap_loc=Loc_unknown; + ap_func=Lvar obj_init; + ap_args=[Lvar self]; + ap_tailcall=Default_tailcall; + ap_inlined=Default_inline; + ap_specialised=Default_specialise; + } in let _, path_lam, obj_init' = transl_class_rebind_0 ~scopes self obj_init0 cl vf in diff --git a/lambda/translcore.ml b/lambda/translcore.ml index 9c5913f48e..f8a68166d0 100644 --- a/lambda/translcore.ml +++ b/lambda/translcore.ml @@ -259,7 +259,7 @@ and transl_exp0 ~scopes e = in if extra_args = [] then lam else begin - let should_be_tailcall, funct = + let tailcall, funct = Translattribute.get_tailcall_attribute funct in let inlined, funct = @@ -270,11 +270,11 @@ and transl_exp0 ~scopes e = in let e = { e with exp_desc = Texp_apply(funct, oargs) } in event_after ~scopes e - (transl_apply ~scopes ~should_be_tailcall ~inlined ~specialised + (transl_apply ~scopes ~tailcall ~inlined ~specialised lam extra_args (of_location ~scopes e.exp_loc)) end | Texp_apply(funct, oargs) -> - let should_be_tailcall, funct = + let tailcall, funct = Translattribute.get_tailcall_attribute funct in let inlined, funct = @@ -285,7 +285,7 @@ and transl_exp0 ~scopes e = in let e = { e with exp_desc = Texp_apply(funct, oargs) } in event_after ~scopes e - (transl_apply ~scopes ~should_be_tailcall ~inlined ~specialised + (transl_apply ~scopes ~tailcall ~inlined ~specialised (transl_exp ~scopes funct) oargs (of_location ~scopes e.exp_loc)) | Texp_match(arg, pat_expr_list, [], partial) -> transl_match ~scopes e arg pat_expr_list partial @@ -476,14 +476,16 @@ and transl_exp0 ~scopes e = event_after ~scopes e lam | Texp_new (cl, {Location.loc=loc}, _) -> let loc = of_location ~scopes loc in - Lapply{ap_should_be_tailcall=false; - ap_loc=loc; - ap_func= - Lprim(Pfield (0, Pointer, Mutable), - [transl_class_path loc e.exp_env cl], loc); - ap_args=[lambda_unit]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} + Lapply{ + ap_loc=loc; + ap_func= + Lprim(Pfield (0, Pointer, Mutable), + [transl_class_path loc e.exp_env cl], loc); + ap_args=[lambda_unit]; + ap_tailcall=Default_tailcall; + ap_inlined=Default_inline; + ap_specialised=Default_specialise; + } | Texp_instvar(path_self, path, _) -> let loc = of_location ~scopes e.exp_loc in let self = transl_value_path loc e.exp_env path_self in @@ -499,12 +501,14 @@ and transl_exp0 ~scopes e = let self = transl_value_path loc e.exp_env path_self in let cpy = Ident.create_local "copy" in Llet(Strict, Pgenval, cpy, - Lapply{ap_should_be_tailcall=false; - ap_loc=Loc_unknown; - ap_func=Translobj.oo_prim "copy"; - ap_args=[self]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise}, + Lapply{ + ap_loc=Loc_unknown; + ap_func=Translobj.oo_prim "copy"; + ap_args=[self]; + ap_tailcall=Default_tailcall; + ap_inlined=Default_inline; + ap_specialised=Default_specialise; + }, List.fold_right (fun (path, _, expr) rem -> let var = transl_value_path loc e.exp_env path in @@ -678,8 +682,12 @@ and transl_tupled_cases ~scopes patl_expr_list = List.map (fun (patl, guard, expr) -> (patl, transl_guard ~scopes guard expr)) patl_expr_list -and transl_apply ~scopes ?(should_be_tailcall=false) ?(inlined = Default_inline) - ?(specialised = Default_specialise) lam sargs loc = +and transl_apply ~scopes + ?(tailcall=Default_tailcall) + ?(inlined = Default_inline) + ?(specialised = Default_specialise) + lam sargs loc + = let lapply funct args = match funct with Lsend(k, lmet, lobj, largs, _) -> @@ -689,12 +697,14 @@ and transl_apply ~scopes ?(should_be_tailcall=false) ?(inlined = Default_inline) | Lapply ap -> Lapply {ap with ap_args = ap.ap_args @ args; ap_loc = loc} | lexp -> - Lapply {ap_should_be_tailcall=should_be_tailcall; - ap_loc=loc; - ap_func=lexp; - ap_args=args; - ap_inlined=inlined; - ap_specialised=specialised;} + Lapply { + ap_loc=loc; + ap_func=lexp; + ap_args=args; + ap_tailcall=tailcall; + ap_inlined=inlined; + ap_specialised=specialised; + } in let rec build_apply lam args = function (None, optional) :: l -> @@ -1173,12 +1183,14 @@ and transl_letop ~scopes loc env let_ ands param case partial = let exp = transl_exp ~scopes and_.bop_exp in let lam = bind Strict right_id exp - (Lapply{ap_should_be_tailcall = false; - ap_loc = of_location ~scopes and_.bop_loc; - ap_func = op; - ap_args=[Lvar left_id; Lvar right_id]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise}) + (Lapply{ + ap_loc = of_location ~scopes and_.bop_loc; + ap_func = op; + ap_args=[Lvar left_id; Lvar right_id]; + ap_tailcall = Default_tailcall; + ap_inlined = Default_inline; + ap_specialised = Default_specialise; + }) in bind Strict left_id prev_lam (loop lam rest) in @@ -1200,12 +1212,14 @@ and transl_letop ~scopes loc env let_ ands param case partial = let loc = of_location ~scopes case.c_rhs.exp_loc in Lfunction{kind; params; return; body; attr; loc} in - Lapply{ap_should_be_tailcall = false; - ap_loc = of_location ~scopes loc; - ap_func = op; - ap_args=[exp; func]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} + Lapply{ + ap_loc = of_location ~scopes loc; + ap_func = op; + ap_args=[exp; func]; + ap_tailcall = Default_tailcall; + ap_inlined = Default_inline; + ap_specialised = Default_specialise; + } (* Wrapper for class compilation *) diff --git a/lambda/translcore.mli b/lambda/translcore.mli index 61b1a1d231..dce2d2750d 100644 --- a/lambda/translcore.mli +++ b/lambda/translcore.mli @@ -25,7 +25,7 @@ val pure_module : module_expr -> let_kind val transl_exp: scopes:scopes -> expression -> lambda val transl_apply: scopes:scopes - -> ?should_be_tailcall:bool + -> ?tailcall:tailcall_attribute -> ?inlined:inline_attribute -> ?specialised:specialise_attribute -> lambda -> (arg_label * expression option) list diff --git a/lambda/translmod.ml b/lambda/translmod.ml index 3cc1e25348..db04c00392 100644 --- a/lambda/translmod.ml +++ b/lambda/translmod.ml @@ -126,12 +126,14 @@ and apply_coercion_result loc strict funct params args cc_res = loc = loc; body = apply_coercion loc Strict cc_res - (Lapply{ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=Lvar id; - ap_args=List.rev args; - ap_inlined=Default_inline; - ap_specialised=Default_specialise})}) + (Lapply{ + ap_loc=loc; + ap_func=Lvar id; + ap_args=List.rev args; + ap_tailcall=Default_tailcall; + ap_inlined=Default_inline; + ap_specialised=Default_specialise; + })}) and wrap_id_pos_list loc id_pos_list get_field lam = let fv = free_variables lam in @@ -358,12 +360,14 @@ let eval_rec_bindings bindings cont = bind_inits rem | (Id id, Some(loc, shape), _rhs) :: rem -> Llet(Strict, Pgenval, id, - Lapply{ap_should_be_tailcall=false; - ap_loc=Loc_unknown; - ap_func=mod_prim "init_mod"; - ap_args=[loc; shape]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise}, + Lapply{ + ap_loc=Loc_unknown; + ap_func=mod_prim "init_mod"; + ap_args=[loc; shape]; + ap_tailcall=Default_tailcall; + ap_inlined=Default_inline; + ap_specialised=Default_specialise; + }, bind_inits rem) and bind_strict = function [] -> @@ -381,13 +385,16 @@ let eval_rec_bindings bindings cont = | (_, None, _rhs) :: rem -> patch_forwards rem | (Id id, Some(_loc, shape), rhs) :: rem -> - Lsequence(Lapply{ap_should_be_tailcall=false; - ap_loc=Loc_unknown; - ap_func=mod_prim "update_mod"; - ap_args=[shape; Lvar id; rhs]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise}, - patch_forwards rem) + Lsequence( + Lapply { + ap_loc=Loc_unknown; + ap_func=mod_prim "update_mod"; + ap_args=[shape; Lvar id; rhs]; + ap_tailcall=Default_tailcall; + ap_inlined=Default_inline; + ap_specialised=Default_specialise; + }, + patch_forwards rem) in bind_inits bindings @@ -512,12 +519,13 @@ and transl_module ~scopes cc rootpath mexp = in oo_wrap mexp.mod_env true (apply_coercion loc Strict cc) - (Lapply{ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=transl_module ~scopes Tcoerce_none None funct; - ap_args=[transl_module ~scopes ccarg None arg]; - ap_inlined=inlined_attribute; - ap_specialised=Default_specialise}) + (Lapply{ + ap_loc=loc; + ap_func=transl_module ~scopes Tcoerce_none None funct; + ap_args=[transl_module ~scopes ccarg None arg]; + ap_tailcall=Default_tailcall; + ap_inlined=inlined_attribute; + ap_specialised=Default_specialise}) | Tmod_constraint(arg, _, _, ccarg) -> transl_module ~scopes (compose_coercions cc ccarg) rootpath arg | Tmod_unpack(arg, _) -> @@ -1428,27 +1436,32 @@ let toplevel_name id = with Not_found -> Ident.name id let toploop_getvalue id = - Lapply{ap_should_be_tailcall=false; - ap_loc=Loc_unknown; - ap_func=Lprim(Pfield (toploop_getvalue_pos, Pointer, Mutable), - [Lprim(Pgetglobal toploop_ident, [], Loc_unknown)], - Loc_unknown); - ap_args=[Lconst(Const_base( - Const_string (toplevel_name id, Location.none,None)))]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} + Lapply{ + ap_loc=Loc_unknown; + ap_func=Lprim(Pfield (toploop_getvalue_pos, Pointer, Mutable), + [Lprim(Pgetglobal toploop_ident, [], Loc_unknown)], + Loc_unknown); + ap_args=[Lconst(Const_base( + Const_string (toplevel_name id, Location.none, None)))]; + ap_tailcall=Default_tailcall; + ap_inlined=Default_inline; + ap_specialised=Default_specialise; + } let toploop_setvalue id lam = - Lapply{ap_should_be_tailcall=false; - ap_loc=Loc_unknown; - ap_func=Lprim(Pfield (toploop_setvalue_pos, Pointer, Mutable), - [Lprim(Pgetglobal toploop_ident, [], Loc_unknown)], - Loc_unknown); - ap_args=[Lconst(Const_base( - Const_string (toplevel_name id, Location.none, None))); - lam]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} + Lapply{ + ap_loc=Loc_unknown; + ap_func=Lprim(Pfield (toploop_setvalue_pos, Pointer, Mutable), + [Lprim(Pgetglobal toploop_ident, [], Loc_unknown)], + Loc_unknown); + ap_args= + [Lconst(Const_base( + Const_string(toplevel_name id, Location.none, None))); + lam]; + ap_tailcall=Default_tailcall; + ap_inlined=Default_inline; + ap_specialised=Default_specialise; + } let toploop_setvalue_id id = toploop_setvalue id (Lvar id) diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml index 9a0b75db9c..bc942c27c8 100644 --- a/middle_end/closure/closure.ml +++ b/middle_end/closure/closure.ml @@ -945,12 +945,14 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = kind = Curried; return = Pgenval; params = List.map (fun v -> v, Pgenval) final_args; - body = Lapply{ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=(Lvar funct_var); - ap_args=internal_args; - ap_inlined=Default_inline; - ap_specialised=Default_specialise}; + body = Lapply{ + ap_loc=loc; + ap_func=(Lvar funct_var); + ap_args=internal_args; + ap_tailcall=Default_tailcall; + ap_inlined=Default_inline; + ap_specialised=Default_specialise; + }; loc; attr = default_function_attribute}) in @@ -1071,12 +1073,15 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = close env arg | Lprim(Pdirapply,[funct;arg], loc) | Lprim(Prevapply,[arg;funct], loc) -> - close env (Lapply{ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=funct; - ap_args=[arg]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise}) + close env + (Lapply{ + ap_loc=loc; + ap_func=funct; + ap_args=[arg]; + ap_tailcall=Default_tailcall; + ap_inlined=Default_inline; + ap_specialised=Default_specialise; + }) | Lprim(Pgetglobal id, [], loc) -> let dbg = Debuginfo.from_location loc in check_constant_result (getglobal dbg id) diff --git a/middle_end/flambda/closure_conversion.ml b/middle_end/flambda/closure_conversion.ml index 8df123f498..0dd0f972bf 100644 --- a/middle_end/flambda/closure_conversion.ml +++ b/middle_end/flambda/closure_conversion.ml @@ -225,8 +225,8 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = in Flambda.create_let set_of_closures_var set_of_closures (name_expr (Project_closure (project_closure)) ~name) - | Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall = _; - ap_inlined; ap_specialised; } -> + | Lapply { ap_func; ap_args; ap_loc; + ap_tailcall = _; ap_inlined; ap_specialised; } -> Lift_code.lifting_helper (close_list t env ap_args) ~evaluation_order:`Right_to_left ~name:Names.apply_arg @@ -418,10 +418,10 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = { ap_func = funct; ap_args = [arg]; ap_loc = loc; - ap_should_be_tailcall = false; (* CR-someday lwhite: it would be nice to be able to give - inlined attributes to functions applied with the application + application attributes to functions applied with the application operators. *) + ap_tailcall = Default_tailcall; ap_inlined = Default_inline; ap_specialised = Default_specialise; } |